(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.

Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Datatypes.Prod.

Require Import Cava.Util.Byte.
Require Import Cava.Types.
Require Import Cava.Expr.
Require Import Cava.Primitives.
Require Import Cava.TLUL.
Require Import Cava.Invariant.
Require Import Cava.Primitives.
Require Import Cava.Semantics.
Require Import Cava.Expr.
Require Import Cava.ExprProperties.
Require Import Cava.Util.Tactics.
Require Import Cava.Util.List.
Require Import Cava.Util.If.
Require Import Cava.Util.Nat.
Require Import Cava.Util.Byte.

Require Import HmacHardware.Hmac.
Require Import HmacHardware.Sha256.
Require Import HmacHardware.Sha256InnerProperties.
Require Import HmacHardware.Sha256PadderProperties.
Require Import HmacHardware.Sha256Properties.
Require Import HmacSpec.SHA256Properties.

Import ListNotations.

Local Notation ShaRepr :=
  (list Byte.byte * bool * nat * nat * nat * bool)%type.
Local Notation FifoRepr :=
  (list N * list Byte.byte * bool * list Byte.byte)%type.

Local Notation HmacInnerSpecRepr :=
  ( nat
  * bool
  * bool
  * bool
  * bool
  * option (list N)
  * bool
  * ShaRepr
  )%type.

Instance hmac_inner_invariant : invariant_for hmac_inner HmacInnerSpecRepr :=
  fun circuit_state '(state, input_done, raised_process, sha_signaled_done, sha_ready, digest_buf, has_content, sha_repr) =>
  let
    '( (finishing, (waiting_for_digest, (accept_fifo, (ptr, (inner_state, (digest, circ_sha_ready))))))
    , circuit_sha_state) := circuit_state in

  let '((ready, (block, (digest1, (count, done)))),
        (sha256_padder_state, sha256_inner_state)) := circuit_sha_state in

  let '(msg, msg_complete, padder_byte_index, inner_byte_index, t, cleared) := sha_repr in

     sha256_invariant circuit_sha_state sha_repr
  /\ (state = 0 \/ state = 2 \/ state = 3)
  /\ (inner_state = N.of_nat state)
  /\ (if state =? 3 then input_done = true else True)
  /\ (if msg_complete then input_done = true else True)

  /\ sha_ready = circ_sha_ready
  /\ (if state =? 3 then sha_signaled_done = negb waiting_for_digest else True )
  /\ (if state =? 0 then True else if has_content then cleared = false /\ msg <> [] else True)
  /\ (if state =? 3 then has_content = true else True )
  /\ (if state =? 3 then msg <> [] else True )
  /\ (if state =? 3 then
    (match digest_buf with
    | Some x =>
        x = BigEndianBytes.bytes_to_Ns 4 (SHA256.sha256 msg)
        /\ waiting_for_digest = false
        /\ digest = x
    | _ => waiting_for_digest = true
     end) else digest_buf = None)
  .

Instance hmac_inner_specification
  : specification_for hmac_inner HmacInnerSpecRepr := {|

  reset_repr := (0, false, false, false, false, None, false, reset_repr);

  precondition
    (input : denote_type (input_of hmac_inner))
    '(state, input_done, raised_process, sha_signaled_done, sha_ready, digest_buf, _, sha_repr) :=
    let
      '(fifo_valid, (fifo_data, (fifo_length, (fifo_final,
        (cmd_hash_start, (cmd_hash_process, (cmd_hmac_enable, (hmac_key_vec, tt)))))))) := input
    in
    let '(msg, msg_complete, padder_byte_index, inner_byte_index, t, cleared) := sha_repr in

    (* ** SHA256 conditions : ** *)
    (* the total message length (including any new data) cannot exceed 2 ^
       64 bits (2^61 bytes) -- using N so Coq doesn't try to compute 2 ^ 61
       in nat *)
    (N.of_nat (length msg) + (if fifo_final then fifo_length else 4) < 2 ^ 61)%N
     (* ...and if data is valid, it must be in expected range *)
     /\ (if fifo_valid
        then if fifo_final
             then (fifo_data < 2 ^ (8 * fifo_length))%N
                  /\ (1 <= fifo_length <= 4)%N
             else (fifo_data < 2 ^ 32)%N
        else True)

    /\ (if fifo_final then fifo_valid = true else True)
    (* Disable cmd_hmac_enable mode for this spec by only allowing
    cmd_hmac_enable flag during idle moments *)
    /\ (if cmd_hmac_enable then (state = 0 /\ cmd_hash_start <> true) else True)
    /\ (if cmd_hash_process then (state = 2 \/ state = 3) else raised_process = false)
    /\ (if state =? 0 then fifo_valid = false else cmd_hash_start = true)
    /\ (if cmd_hash_start then True else fifo_valid = false)

    (* no valid input after fifo_final *)
    /\ (if input_done then fifo_valid = false else True)

    (* cmd_hash_process must be continuously asserted *)
    /\ (if raised_process then cmd_hash_process  = true else True);

  update_repr (input : denote_type (input_of hmac_inner))
    '(state, input_done, raised_process, sha_signaled_done, sha_ready, digest_buf, has_content, sha_repr) :=

    let
      '(fifo_valid, (fifo_data, (fifo_length, (fifo_final,
        (cmd_hash_start, (cmd_hash_process, (cmd_hmac_enable, (hmac_key_vec, tt)))))))) := input
    in

    let fifo_valid := if sha_ready then fifo_valid else false in

    let sha_input :=
      (* Only emulate sha mode *)
      match state with
      | 0 => (false, (0%N, (false, (0%N, (true, tt)))))
      | 2 => (fifo_valid, (fifo_data, (fifo_final, (fifo_length, (false, tt)))))%bool
      | _ => (false, (0%N, (false, (0%N, (false, tt)))))
      end
    in

    let sha_repr' := update_repr (c:=sha256) sha_input sha_repr in
    let '(msg, msg_complete, padder_byte_index, inner_byte_index, t, cleared) := sha_repr
    in

    let clear := if state =? 0 then true else false in
    let is_cleared := if clear
                      then true
                      else if (cleared:bool)
                           then negb (fst sha_input)
                           else false in

    let count_16_pre :=
        if (if (padder_byte_index =? 64) then t =? 0 else t =? 64)
        then if (padder_byte_index =? inner_byte_index + 64) then true else false else false
    in
    let count_le15_pre :=
        if (padder_byte_index <? 64) then t =? 0 else t =? 64
    in

    let is_cleared_or_done :=
        if is_cleared
        then true
        else if fifo_valid
             then false
             else
               if count_16_pre
               then false
               else
                if (padder_byte_index =? padded_message_size msg) then if (t =? 64) then true else false else false
    in

    let state' :=
      match state with
      | 0 => if cmd_hash_start then 2 else 0
      | 2 => if sha_ready then if cmd_hash_process then if fifo_final then 3 else 2 else 2 else 2
      | 3 => if sha_signaled_done then 0 else 3
      | _ => 0
      end in

    (* new value of [t] *)
    let new_t :=
        if clear
        then 0
        else if cleared
             then 0
             else if (padder_byte_index =? inner_byte_index)
                  then if t =? 64
                       then t
                       else S t
                  else if (padder_byte_index =? inner_byte_index + 64)
                       then 0
                       else t in

    (* ready for new input only if the inner loop is done and the padder is
       not *)
    let is_ready :=
        if is_cleared
        then true
        else
          if count_16_pre then false
          else if count_le15_pre then
            if (if padder_byte_index =? padded_message_size msg
              then fifo_valid
              else if (msg_complete: bool) then true else fifo_valid)
            then padder_byte_index mod 64 <=? 56
            else true
          else if inner_byte_index =? padder_byte_index
            then
              if if (t =? 64)%nat then true else (inner_byte_index =? 0)%nat
              then true
              else (t =? 63)%nat
            else true
    in

    let input_done' :=
      if state =? 0
      then false
      else
        if input_done
        then true
        else if fifo_final then sha_ready else false
    in

    let raised_process' :=
      if state' =? 0
      then false
      else
        if cmd_hash_process
        then true
        else raised_process
    in

    let digest_buf :=
      if state =? 3 then
        if state' =? 0 then None
        else
          if is_cleared_or_done
          then Some (BigEndianBytes.bytes_to_Ns 4 (SHA256.sha256 msg))
          else None
      else None
    in

    let has_content' :=
      if state =? 0 then false
      else
        if has_content then true else fifo_valid
      (* 0 <? length msg *)
    in

    (state', input_done', raised_process', is_cleared_or_done, is_ready, digest_buf,
      has_content',
      sha_repr');

  postcondition
    (input : denote_type (input_of hmac_inner))
    '(state, input_done, raised_process, sha_signaled_done, sha_ready, digest_buf, _, sha_repr)
    (output : denote_type (output_of hmac_inner)) :=
    let
      '(fifo_valid, (fifo_data, (fifo_length, (fifo_final,
        (cmd_hash_start, (cmd_hash_process, (cmd_hmac_enable, (hmac_key_vec, tt)))))))) := input in

        let fifo_data_valid := if sha_ready then fifo_valid else false in
        let clear := state =? 0 in

    let '(msg, msg_complete, padder_byte_index, inner_byte_index, t, cleared) := sha_repr in
    (* new value of [cleared] *)
    let is_cleared := if clear
                      then true
                      else if cleared
                           then negb fifo_data_valid
                           else false in

    let count_16_pre :=
        if (if (padder_byte_index =? 64) then t =? 0 else t =? 64)
        then if (padder_byte_index =? inner_byte_index + 64) then true else false else false
    in
    let count_le15_pre :=
        if (padder_byte_index <? 64) then t =? 0 else t =? 64
    in

    let is_cleared_or_done :=
        if is_cleared
        then true
        else if fifo_data_valid
             then false
             else
               if count_16_pre
               then false
               else
                if (padder_byte_index =? padded_message_size msg) then if (t =? 64) then true else false else false
    in

    (* new value of [padder_byte_index] *)
    let new_padder_byte_index :=
        if clear
        then 0
        else if cleared
         then 0
         else if (padder_byte_index =? inner_byte_index)
              then if t =? 64
                   then if (padder_byte_index =? padded_message_size msg)
                        then padder_byte_index
                        else if msg_complete
                             then padder_byte_index + 4
                             else if fifo_data_valid
                                  then padder_byte_index + 4
                                  else padder_byte_index
                   else padder_byte_index
              else if (padder_byte_index =? inner_byte_index + 64)
                   then padder_byte_index
                   else if msg_complete
                        then padder_byte_index + 4
                        else if fifo_data_valid
                             then padder_byte_index + 4
                             else padder_byte_index in

    (* new value of [t] *)
    let new_t :=
        if clear
        then 0
        else if cleared
             then 0
             else if (padder_byte_index =? inner_byte_index)
                  then if t =? 64
                       then t
                       else S t
                  else if (padder_byte_index =? inner_byte_index + 64)
                       then 0
                       else t in

    (* ready for new input only if the inner loop is done and the padder is
       not *)
    let is_ready :=
        if is_cleared
        then true
        else
          if count_16_pre then false
          else if count_le15_pre then
            if (if padder_byte_index =? padded_message_size msg
              then fifo_data_valid
              else if msg_complete then true else fifo_data_valid)
            then padder_byte_index mod 64 <=? 56
            else true
          else if inner_byte_index =? padder_byte_index
            then
              if if (t =? 64)%nat then true else (inner_byte_index =? 0)%nat
              then true
              else (t =? 63)%nat
            else true
    in

    let accept_fifo := if state =? 2 then is_ready else false in

    exists done odigest,
      output = (accept_fifo, (done, odigest))
      /\ match digest_buf with
         | Some x => done = true /\ odigest = x
         | _ => done = false
         end
|}.

(* TODO: move me *)
Ltac nat_const X :=
  match X with
  | O => idtac
  | S ?Y => nat_const Y
  | _ => fail
  end.
Ltac destr_nat_match :=
  match goal with
  | |- context [?X =? ?Y] =>
      nat_const X; nat_const Y;
      destr (X =? Y); try lia
  end.
Ltac destr_nat_match_hyp :=
  match goal with
  | _: context [?X =? ?Y] |- _ =>
      nat_const X; nat_const Y;
      destr (X =? Y); try lia
  end.

Ltac fail_if_if_in X :=
  lazymatch X with
  | context [if _ then _ else _] => fail
  | _ => idtac
  end.

Ltac destruct_one_inner_match :=
  match goal with
  | |- context [if ?B then _ else _] => fail_if_if_in B; destr B
  end.

Local Hint Unfold
      hmac_inner_state
      hmac_inner_local_state
      sha256_state
      sha256_outer_state
      padder_state
      sha256_inner_state
  : stepsimpl.

Lemma hmac_inner_invariant_at_reset :
  invariant_at_reset hmac_inner.
Proof.
  simplify_invariant hmac_inner.
  cbn [reset_repr reset_state hmac_inner hmac_inner_specification sha256 sha256_specification default].
  stepsimpl.

  ssplit;
    lazymatch goal with
    | |- sha256_invariant _ _ => apply sha256_invariant_at_reset
    | _ => reflexivity || lia || idtac
    end.
Qed.

Lemma hmac_inner_invariant_preserved :
  invariant_preserved hmac_inner.
Proof.
  simplify_invariant hmac_inner. cbn [absorb_any].
  simplify_spec hmac_inner.

  intros input state repr new_repr.
  pose (input_:=input). pose (state_:=state). pose (repr_:=repr). pose (new_repr_:=new_repr).
  revert dependent repr. revert dependent state. revert dependent input. revert dependent new_repr.

  intros (((((((new_state, new_input_done), new_raised_process), new_sha_signaled_done), new_sha_ready), new_digest), has_content), new_sha_repr).
  intro.
  intros (fifo_valid, (fifo_data, (fifo_length, (fifo_final,
         (cmd_hash_start, (cmd_hash_process, (cmd_hmac_enable, (hmac_key_vec, [])))))))).
  intro.
  intros
      ( (finishing, (waiting_for_digest, (accept_fifo, (ptr, (inner_state, (digest_circ, sha_ready_circ))))))
      , sha_state_circ).
  intro.
  intros (((((((state, input_done), raised_process), sha_signaled_done), sha_ready), digest), new_has_content), sha_repr).
  intro.
  destruct sha_repr as (((((msg,msg_complete),?),?),?),?).
  destruct new_sha_repr as (((((?,?),?),?),?),?).
  destruct sha_state_circ as ((ready, (?, (?, (?, ?)))), (padder, inner)).
  destruct padder as (?, (?, (?, (?, (?, ?))))).
  destruct inner as (?, (?, (?, ?))).
  intros.

  (* for some reason the modulo expands into ugly match statement without this *)
  remember (n mod 64) as n_mod_64.
  logical_simplify. subst.

  cbv [hmac_inner K]. cbn [negb]. stepsimpl.
  repeat (destruct_pair_let; cbn [fst snd]).

  lazymatch goal with
  | H : sha256_invariant ?state ?repr
    |- context [step sha256 ?state ?input] =>
    assert (precondition sha256 input repr)
  end.
  { simplify_spec sha256. cbn [reset_repr sha256_specification denote_type] in *.
    autorewrite with Nnat.
    logical_simplify; subst; try lia.

    destr (state =? 7); try lia.
    destr (state =? 6); try lia.
    destr (state =? 5); try lia.
    destr (state =? 4); try lia.
    destr (state =? 1); try lia.

    destr (state =? 3); logical_simplify; subst; try lia;
    [|destr (state =? 0); logical_simplify; subst; try lia;
    [|destr (state =? 2); logical_simplify; subst; try lia]].
    all:
      repeat (match goal with
                  | |- context [ ?X =? ?Y ] => destr ( X =? Y); try lia
                  | |- context [ ?X <=? ?Y ] => destr ( X <=? Y); try lia
                  | |- context [ ( ?X =? ?Y )%N ] => destr ( X =? Y)%N; try lia
                  | |- context [ ( ?X <=? ?Y )%N ] => destr ( X <=? Y)%N; try lia
                  end; try lia); boolsimpl.
    all: cbn [fst snd].
    all: try rewrite Tauto.if_same.
    all: rewrite ?List.app_nil_r.
    all: cbv [new_msg_bytes].
    all: try (destruct msg_complete); try (ssplit; lia).
    all: destruct sha_ready_circ.
    all: try (push_length; ssplit; lia).
    all: destruct fifo_valid.
    all: try (push_length; ssplit; lia).
    all: destruct fifo_final; try lia.
    all: try (push_length; ssplit; lia).
    all: destruct input_done; try lia.
  }

  ssplit.
  {
    cbn [fst snd] in *.
    match goal with
    | |- context [ @step ?i ?s ?o sha256 ?state ?input ] =>
        epose proof (@invariant_preserved_pf s i o sha256 ShaRepr _ _ sha256_correctness input state
        (msg, msg_complete, n, n0, n1, b) (l, b0, n2, n3, n4, b1) _ H0 H
        ) as HX
        ; remember (fst (@step i s o sha256 state input)) as step_sha
    end.

    cbn [denote_type absorb_any sha_block sha_digest sha_word fst snd] in *.
    destruct_products.
    repeat (inversion_prod; cbn [fst snd] in *).
    apply HX.
    Unshelve.
    cbn [update_repr sha256_specification].
    repeat (rewrite <- tup_if; cbn [fst snd]).
    repeat inversion_prod.
    subst.
    autorewrite with Nnat.
    destruct state.
    {
      repeat destr_nat_match.
      now cbn [fst snd].
    }
    destruct state.
    { repeat destr_nat_match.  }
    destruct state.
    {
      repeat destr_nat_match.
      repeat (rewrite <- tup_if; cbn [fst snd]).
      reflexivity.
    }
    destruct state.
    {
      replace (N.to_nat 4) with 4 by lia.
      replace (N.to_nat 5) with 5 by lia.
      replace (N.to_nat 6) with 6 by lia.
      repeat destr_nat_match.
      repeat destr_nat_match_hyp.
      subst.
      repeat (rewrite <- tup_if; cbn [fst snd]).
      destruct b.
      all: rewrite ?Tauto.if_same.
      { reflexivity. }
      { reflexivity. }
    }
    lia.
  }
  { repeat (destruct_one_match); lia. }
  { autorewrite with Nnat.
    destruct cmd_hmac_enable; try lia.
    { destruct state.
      { all: cbn; boolsimpl.
        now destruct cmd_hash_start.
      }
      lia.
    }

    destruct state; cbn [fst] in *.
    all: cbn; boolsimpl.
    { now destruct cmd_hash_start. }
    destruct state; cbn [fst] in *.
    { lia. }
    destruct state; [destruct b|]; cbn [fst] in *.
    all: cbn; boolsimpl.
    {
      destruct sha_ready_circ, fifo_valid; boolsimpl; cbn [fst]; try lia.
      all: destruct cmd_hash_process, fifo_final; boolsimpl; try lia.
    }
    {
      destruct fifo_final; logical_simplify; subst; try lia.
      all: repeat (destruct_one_match; try lia).
    }

    destruct state; cbn [fst] in *.
    all: cbn; boolsimpl.
    { destruct waiting_for_digest, sha_signaled_done;
      repeat destr_nat_match_hyp;
      subst; boolsimpl; try lia. }
    lia.
  }
  {
    destruct state.
    { destruct cmd_hash_start; destruct_one_match; cbn [fst snd]; congruence. }
    destruct state.
    { lia. }
    destruct state.
    {
      destr_nat_match.
      repeat destruct_one_inner_match; try lia.
    }
    destruct state; [|try lia].
    repeat destr_nat_match; repeat destruct_one_inner_match; try lia.
  }
  {
    destr (state =?0); try lia.
    {
      subst; cbn [fst snd].
      intros; logical_simplify; subst.
      trivial.
    }
    destr (state =?2).
    {
      destruct b0; [|trivial].
      logical_simplify; subst.
      repeat destr_nat_match_hyp; repeat destr_nat_match; repeat destruct_one_inner_match; try lia.
      all: destruct msg_complete; [lia|].
      all: repeat inversion_prod; revert H23; repeat (rewrite <- tup_if; cbn [fst snd]).
      all: destruct sha_ready_circ; try lia; boolsimpl.
      all: rewrite ?Tauto.if_same; now intros.
    }
    destr (state =? 3); try lia.
    subst state input_done.
    destruct b0; trivial.
  }

  {
    use_correctness' sha256.
    destruct state.
    {
      autorewrite with Nnat.
      repeat destr_nat_match.
      repeat destr_nat_match_hyp.
      now cbn.
    }

    destruct state.
    { destr_nat_match. }

    destruct state.
    {
      autorewrite with Nnat.
      repeat destr_nat_match.
      repeat destr_nat_match_hyp.
      cbn [fst snd] in *.

      subst; cbn [fst snd].
      cbv [andb].
      destruct sha_ready_circ, fifo_valid; boolsimpl; try reflexivity.
    }

    destruct state.
    {
      autorewrite with Nnat.
      replace (N.to_nat 4) with 4 by lia.
      replace (N.to_nat 5) with 5 by lia.
      repeat destr_nat_match.
      repeat destr_nat_match_hyp.
      cbn [fst snd] in *.
      subst.
      rewrite ?Tauto.if_same.
      reflexivity.
    }

    lia.
  }

  {
    use_correctness' sha256.
    destruct state.
    {
      replace ((if cmd_hash_start then 2 else 0) =? 3) with false
        by (destruct_one_match; destr_nat_match; lia).
      trivial.
    }

    destruct state.
    { destr_nat_match. }

    destruct state.
    {
      autorewrite with Nnat.
      repeat destr_nat_match.
      repeat destr_nat_match_hyp.
      cbn [fst snd] in *.
      boolsimpl.
      destruct sha_ready_circ, cmd_hash_process; boolsimpl; try reflexivity.
      destruct fifo_final; logical_simplify; subst; destr_nat_match; try lia.
      rewrite ?Tauto.if_same.
      destr_nat_match; boolsimpl.
      reflexivity.
    }

    destruct state.
    {
      autorewrite with Nnat.
      replace (N.to_nat 4) with 4 by lia.
      replace (N.to_nat 5) with 5 by lia.
      replace (N.to_nat 6) with 6 by lia.
      repeat destr_nat_match.
      repeat destr_nat_match_hyp.
      boolsimpl.
      cbn [fst snd] in *.
      boolsimpl.
      destruct cmd_hmac_enable; try lia.
      destruct sha_signaled_done, sha_ready_circ, cmd_hash_process;
        repeat (destr_nat_match; boolsimpl); try reflexivity.
      all: destruct b; boolsimpl; try reflexivity.
      all: rewrite ?Tauto.if_same.
      all: try reflexivity.

      all: destruct fifo_valid, waiting_for_digest; boolsimpl; repeat destr_nat_match; try reflexivity.
      all: subst; try lia.
    }

    lia.
  }

  {
    assert (forall {A} (ls: list A), length ls > 0 -> ls <> []) as Hx.
    { clear; intros; now destruct ls. }

    destruct state.
    { repeat destr_nat_match.
      destruct cmd_hash_start; destr_nat_match; reflexivity.
    }
    destruct state.
    { repeat destr_nat_match. }
    destruct state.
    {
      repeat destr_nat_match.
      repeat destr_nat_match_hyp.

      destruct sha_ready_circ; repeat destr_nat_match.
      {
        assert ((if cmd_hash_process then if fifo_final then 3 else 2 else 2) =? 0 = false).
        { repeat destruct_one_inner_match; destr_nat_match. }
        rewrite H11.
        destruct new_has_content.
        {
          repeat inversion_prod.
          logical_simplify; subst.
          autorewrite with tuple_if.
          cbn [fst snd].
          split.
          { now rewrite ?Tauto.if_same. }
          { repeat destruct_one_inner_match; cbn [new_msg_bytes]; try trivial.
            all: apply Hx; push_length.
            all: destruct msg; try congruence.
            all: cbn [length]; lia.
          }
        }
        destruct fifo_valid; try trivial.
        repeat inversion_prod.
        subst.
        autorewrite with tuple_if.
        cbn [fst snd].
        split.
        { rewrite ?Tauto.if_same. now destruct b. }
        { apply Hx; destruct b; cbn [new_msg_bytes].
          { destruct fifo_final; length_hammer. }
          repeat destruct_one_inner_match.
          all: try length_hammer.
          all: simplify_invariant sha256; logical_simplify; subst.
          all: try congruence.
          all: try (destruct msg_complete; logical_simplify; subst; try lia).
        }
      }
      repeat inversion_prod.
      subst.
      autorewrite with tuple_if.
      cbn [fst snd].
      destruct new_has_content; try lia.
      logical_simplify; subst.
      split.
      { now rewrite ?Tauto.if_same. }
      repeat destruct_one_inner_match; trivial.
    }
    destruct state; try lia.
    destruct sha_signaled_done; destr_nat_match.
    destruct new_has_content; [|destruct sha_ready_circ, fifo_valid]; try trivial.
    all: repeat inversion_prod; subst; autorewrite with tuple_if; cbn [fst snd];
          logical_simplify; subst; split;

      [ rewrite ?Tauto.if_same |
      repeat destruct_one_inner_match; trivial].
    { reflexivity. }
    all: destr_nat_match_hyp; logical_simplify; subst.
    all: congruence.
  }

  {
    destruct state.
    { destruct_one_inner_match; destr_nat_match; trivial. }
    destruct state; try lia.
    destruct state.
    { repeat destruct_one_inner_match; repeat destr_nat_match; try lia.
      trivial.
    }
    destruct state; try lia.
    { repeat destruct_one_inner_match; repeat destr_nat_match; try lia.
    }
  }

  {
    assert (forall {A} (ls: list A), length ls > 0 -> ls <> []) as Hx.
    { clear; intros; now destruct ls. }
    destruct state.
    { destruct_one_inner_match; destr_nat_match; trivial. }

    destruct state; try lia.
    destruct state.
    { repeat destruct_one_inner_match; repeat destr_nat_match;
        repeat destr_nat_match_hyp; logical_simplify; subst; try trivial.
      destruct msg_complete; logical_simplify; subst; try lia.
      destruct input_done; logical_simplify; subst; try lia.

      repeat inversion_prod.
      destruct new_has_content.
      all: subst; autorewrite with tuple_if; cbn [fst snd].
      all: logical_simplify; subst.
      all: simplify_invariant sha256.
      all: repeat destruct_one_inner_match; try trivial.
      all: apply Hx; cbn [new_msg_bytes]; push_length; try lia.

    }

    destruct state; try destruct_one_inner_match; repeat destr_nat_match; try lia.
    {
      repeat inversion_prod.
      subst; autorewrite with tuple_if; cbn [fst snd].
      simplify_invariant sha256.
      repeat destruct_one_inner_match; try trivial.
      repeat destr_nat_match_hyp; logical_simplify; subst.
    }
  }

  { destruct state.
    { repeat destr_nat_match.
      destruct cmd_hash_start; destr_nat_match; reflexivity.
    }
    destruct state.
    { repeat destr_nat_match. }
    destruct state.

    { repeat destr_nat_match.
      destruct sha_ready_circ, cmd_hash_process, fifo_final; destr_nat_match.
      all: try reflexivity.
      autorewrite with Nnat.
      repeat destr_nat_match.
      boolsimpl.
      destruct cmd_hmac_enable; try lia.
      use_correctness' sha256.
      cbn [fst snd negb].
      simplify_invariant sha256.
      destr_nat_match.
      destruct b; now boolsimpl.
    }
    destruct state.
    {
      use_correctness' sha256.
      repeat destr_nat_match.
      destruct sha_signaled_done.
      { now repeat destr_nat_match. }
      repeat destr_nat_match.
      cbn [fst snd].
      simplify_invariant sha256.
      destruct b; boolsimpl.
      { logical_simplify; subst.
        split; [reflexivity|].
        destruct cmd_hmac_enable; try lia.
      }
      logical_simplify; subst.
      repeat inversion_prod.
      autorewrite with tuple_if in H6.
      cbn [fst snd] in *.
      rewrite ?Tauto.if_same in H6.
      subst.
      rewrite ?Tauto.if_same.
      match goal with
      | |- match (if ?X then _ else _) with _ => _ end => destr X
      end.
      {
        split; try reflexivity. subst.
        rewrite ?Tauto.if_same.
        split; try reflexivity.

        autorewrite with Nnat in *.
        replace (N.to_nat 4) with 4 in * by lia.
        replace (N.to_nat 5) with 5 in * by lia.
        repeat destr_nat_match_hyp.
        cbn [fst] in *.
        destruct sha_ready_circ; try trivial.
      }
      rewrite ?Tauto.if_same.

      destruct cmd_hmac_enable;try lia.
      autorewrite with Nnat.
      replace (N.to_nat 4) with 4 by lia.
      replace (N.to_nat 5) with 5 by lia.
      replace (N.to_nat 6) with 6 by lia.
      repeat destr_nat_match.
      destruct waiting_for_digest; try lia.
      now boolsimpl.
    }
    lia.
  }

Qed.

Lemma hmac_inner_output_correct :
  output_correct hmac_inner.
Proof.
  simplify_invariant hmac_inner. cbn [absorb_any].
  simplify_spec hmac_inner.

  intros input state repr new_repr.
  pose (input_:=input). pose (state_:=state). pose (repr_:=repr). pose (new_repr_:=new_repr).
  revert dependent repr. revert dependent state. revert dependent input.

  intros (fifo_valid, (fifo_data, (fifo_length, (fifo_final,
         (cmd_hash_start, (cmd_hash_process, (cmd_hmac_enable, (hmac_key_vec, [])))))))).
  intro.
  intros
      ( (finishing, (waiting_for_digest, (accept_fifo, (ptr, (inner_state, (digest_circ, sha_ready_circ))))))
      , sha_state_circ).
  intro.
  intros (((((((state, input_done), raised_process), sha_signaled_done), sha_ready), digest), has_content), sha_repr).
  intro.
  destruct sha_repr as (((((msg,msg_complete),?),?),?),?).
  destruct sha_state_circ as ((ready, (?, (?, (?, ?)))), (padder, inner)).
  destruct padder as (?, (?, (?, (?, (?, ?))))).
  destruct inner as (?, (?, (?, ?))).
  intros.

  (* for some reason the modulo expands into ugly match statement without this *)
  remember (n mod 64) as n_mod_64.
  logical_simplify. subst.

  cbv [hmac_inner K]. cbn [negb]. stepsimpl.
  repeat (destruct_inner_pair_let; cbn [fst snd]).

  lazymatch goal with
  | H : sha256_invariant ?state ?repr
    |- context [step sha256 ?state ?input] =>
    assert (precondition sha256 input repr)
  end.
  { simplify_spec sha256. cbn [reset_repr sha256_specification denote_type] in *.
    autorewrite with Nnat.
    logical_simplify; subst; try lia.

    destr (state =? 7); try lia.
    destr (state =? 6); try lia.
    destr (state =? 5); try lia.
    destr (state =? 4); try lia.
    destr (state =? 1); try lia.

    destr (state =? 3); logical_simplify; subst; try lia;
    [|destr (state =? 0); logical_simplify; subst; try lia;
    [|destr (state =? 2); logical_simplify; subst; try lia]].
    all:
      repeat (match goal with
                  | |- context [ ?X =? ?Y ] => destr ( X =? Y); try lia
                  | |- context [ ?X <=? ?Y ] => destr ( X <=? Y); try lia
                  | |- context [ ( ?X =? ?Y )%N ] => destr ( X =? Y)%N; try lia
                  | |- context [ ( ?X <=? ?Y )%N ] => destr ( X <=? Y)%N; try lia
                  end; try lia); boolsimpl.
    all: cbn [fst snd].
    all: try rewrite Tauto.if_same.
    all: rewrite ?List.app_nil_r.
    all: cbv [new_msg_bytes].
    all: try (destruct msg_complete); try (ssplit; lia).
    all: destruct sha_ready_circ.
    all: try (push_length; ssplit; lia).
    all: destruct fifo_valid.
    all: try (push_length; ssplit; lia).
    all: destruct fifo_final; try lia.
    all: try (push_length; ssplit; lia).
    all: destruct input_done; try lia.
  }

  Ltac use_correctness' c :=
    lazymatch goal with
    | |- context [ @snd ?A ?B (@step ?i ?s ?o c ?state ?input) ] =>
      find_correctness c;
      pose proof (@output_correct_pf
                    s i o c _ _ _ _
                    input state _ ltac:(eassumption) ltac:(eassumption));
      generalize dependent (@snd A B (@step i s o c state input)); intros;
      try simplify_postcondition c
      (* ; logical_simplify *)
      (* ; subst *)
    end.
  use_correctness' sha256.

  destruct H24 as [sha_done].
  destruct H24 as [sha_digest].
  destruct H24 as [sha_ready].
  logical_simplify.

  eexists (match digest with Some _ => true | _ => false end).
  eexists (match digest with Some x => x | _ =>
      match state with
      | 0 => _
      | 2 => _
      | 3 => _
      | _ => SHA256.H0
      end
     end).

  ssplit.
  {
    autorewrite with Nnat in *.
    destruct state; cbn [fst snd].
    { logical_simplify; subst; repeat destr_nat_match; boolsimpl.
      cbn [fst snd].
      subst.
      reflexivity.
    }
    destruct state; [lia|].
    destruct state; cbn [fst snd].
    { logical_simplify; subst; repeat destr_nat_match; boolsimpl.
      cbn [fst snd].
      subst.
      apply f_equal.
      destruct cmd_hmac_enable; try lia.
      assert ((if (sha_ready_circ && cmd_hash_process && fifo_final)%bool then 3 else 2) =? 0 = false)
       by (destruct sha_ready_circ, cmd_hash_process, fifo_final; cbn [andb]; destr_nat_match).
      rewrite H4.
      apply f_equal.

      reflexivity.
    }

    destruct state; cbn [fst snd].
    {
      simplify_invariant sha256.
      repeat destr_nat_match.
      boolsimpl.
      destruct cmd_hmac_enable; try lia.
      apply f_equal.
      destruct digest, waiting_for_digest; logical_simplify; try lia.
      2:{ logical_simplify; subst; boolsimpl; reflexivity. }
      logical_simplify; subst; boolsimpl.

      repeat destr_nat_match.
      autorewrite with Nnat.
      replace (N.to_nat 4) with 4 in * by lia.
      replace (N.to_nat 5) with 5 in * by lia.
      replace (N.to_nat 6) with 6 in * by lia.
      repeat destr_nat_match.
      cbn [fst snd].

      apply f_equal.
      destruct b; try lia.
      rewrite Tauto.if_same.
      simplify_invariant sha256.
      repeat destruct_one_inner_match; try reflexivity.
      all: try lia.
      all: cbn [fst] in *.
      all: rewrite Tauto.if_same in H32.
      all: trivial.
    }
    lia.
  }

  destruct digest; split; reflexivity.
Qed.

Existing Instances hmac_inner_invariant_preserved hmac_inner_output_correct hmac_inner_invariant_at_reset.

Global Instance hmac_inner_correctness : correctness_for hmac_inner.
Proof. constructor; try typeclasses eauto. Defined.


From sflib Require Import sflib.
From Paco Require Import paco.

Require Import Coq.Classes.RelationClasses.
Require Import Program.

From Fairness Require Export ITreeLib FairBeh NatStructs.
From Fairness Require Export Mod ModSimStutter Concurrency.
From Fairness Require Import pind LPCM World.

Set Implicit Arguments.

Section KSIM.

  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable _ident_src: ID.
  Let ident_src := sum_tid _ident_src.
  Variable _ident_tgt: ID.
  Let ident_tgt := sum_tid _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Notation srcE := (programE _ident_src state_src).
  Notation tgtE := (programE _ident_tgt state_tgt).

  Variable wf_stt: Type -> Type -> WF.

  Definition kshared :=
    ((@imap ident_src wf_src) *
       (@imap ident_tgt wf_tgt) *
       state_src *
       state_tgt)%type.

  Definition to_kshared (shr: shared state_src state_tgt _ident_src _ident_tgt wf_src wf_tgt): kshared :=
    let '(ths, im_src, im_tgt, st_src, st_tgt) := shr in
    (im_src, im_tgt, st_src, st_tgt).

  Definition threads2 _id ev R := Th.t (prod bool (@thread _id ev R)).
  Notation threads_src1 R0 := (threads _ident_src (sE state_src) R0).
  Notation threads_src2 R0 := (threads2 _ident_src (sE state_src) R0).
  Notation threads_tgt R1 := (threads _ident_tgt (sE state_tgt) R1).

  Variant __sim_knot R0 R1 (RR: R0 -> R1 -> Prop)
          (sim_knot: threads_src2 R0 -> threads_tgt R1 -> thread_id -> local_resources -> bool -> bool -> (prod bool (itree srcE R0)) -> (itree tgtE R1) -> kshared -> (wf_stt R0 R1).(T) -> Prop)
          (_sim_knot: threads_src2 R0 -> threads_tgt R1 -> thread_id -> local_resources -> bool -> bool -> (prod bool (itree srcE R0)) -> (itree tgtE R1) -> kshared -> (wf_stt R0 R1).(T) -> Prop)
          (thsl: threads_src2 R0) (thsr: threads_tgt R1)
    :
    thread_id -> local_resources -> bool -> bool -> (prod bool (itree srcE R0)) -> itree tgtE R1 -> kshared -> (wf_stt R0 R1).(T) -> Prop :=
    | ksim_ret_term
        tid f_src f_tgt
        sf r_src r_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (RET: RR r_src r_tgt)
        (NILS: Th.is_empty thsl = true)
        (NILT: Th.is_empty thsr = true)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Ret r_src)
                 (Ret r_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o

    | ksim_ret_cont
        tid f_src f_tgt
        sf r_src r_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        o0
        rs_local0 r_own r_shared0
        (UPDRS: rs_local0 = NatMap.add tid r_own rs_local)
        (WF: resources_wf r_shared0 rs_local0)
        (STUTTER: (wf_stt R0 R1).(lt) o0 o)
        (RET: RR r_src r_tgt)
        (NNILS: Th.is_empty thsl = false)
        (NNILT: Th.is_empty thsr = false)
        (KSIM: forall tid0,
            ((nm_pop tid0 thsl = None) /\ (nm_pop tid0 thsr = None)) \/
              (exists b th_src thsl0 th_tgt thsr0,
                  (nm_pop tid0 thsl = Some ((b, th_src), thsl0)) /\
                    (nm_pop tid0 thsr = Some (th_tgt, thsr0)) /\
                    ((b = true) ->
                     (forall im_tgt0
                        (FAIR: fair_update im_tgt im_tgt0 (prism_fmap inlp (tids_fmap tid0 (key_set thsr0)))),
                         (sim_knot thsl0 thsr0 tid0
                                   (snd (get_resource tid0 rs_local0))
                                   true true
                                   (b, Vis (inl1 (inl1 (inr1 Yield))) (fun _ => th_src))
                                   (th_tgt)
                                   (im_src, im_tgt0, st_src, st_tgt) o0))) /\
                    ((b = false) ->
                     (forall im_tgt0
                        (FAIR: fair_update im_tgt im_tgt0 (prism_fmap inlp (tids_fmap tid0 (key_set thsr0)))),
                       exists im_src0,
                         (fair_update im_src im_src0 (prism_fmap inlp (tids_fmap tid0 (key_set thsl0)))) /\
                           (sim_knot thsl0 thsr0 tid0
                                     (snd (get_resource tid0 rs_local0))
                                     true true
                                     (b, th_src)
                                     th_tgt
                                     (im_src0, im_tgt0, st_src, st_tgt) o0)))))
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Ret r_src)
                 (Ret r_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o

    | ksim_sync
        tid f_src f_tgt
        sf ktr_src ktr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        thsl0 thsr0
        rs_local0 r_own r_shared0
        (UPDRS: rs_local0 = NatMap.add tid r_own rs_local)
        (WF: resources_wf r_shared0 rs_local0)
        (THSL: thsl0 = Th.add tid (true, ktr_src tt) thsl)
        (THSR: thsr0 = Th.add tid (ktr_tgt tt) thsr)
        (KSIM: forall tid0,
            ((nm_pop tid0 thsl0 = None) /\ (nm_pop tid0 thsr0 = None)) \/
              (exists b th_src thsl1 th_tgt thsr1,
                  (nm_pop tid0 thsl0 = Some ((b, th_src), thsl1)) /\
                    (nm_pop tid0 thsr0 = Some (th_tgt, thsr1)) /\
                    ((b = true) ->
                     (forall im_tgt0 (FAIR: fair_update im_tgt im_tgt0 (prism_fmap inlp (tids_fmap tid0 (key_set thsr1)))),
                       exists o0, ((wf_stt R0 R1).(lt) o0 o) /\
                               (sim_knot thsl1 thsr1 tid0
                                         (snd (get_resource tid0 rs_local0))
                                         true true
                                         (b, Vis (inl1 (inl1 (inr1 Yield))) (fun _ => th_src))
                                         (th_tgt)
                                         (im_src, im_tgt0, st_src, st_tgt) o0))) /\
                    ((b = false) ->
                     (forall im_tgt0 (FAIR: fair_update im_tgt im_tgt0 (prism_fmap inlp (tids_fmap tid0 (key_set thsr1)))),
                       exists im_src0 o0,
                         (fair_update im_src im_src0 (prism_fmap inlp (tids_fmap tid0 (key_set thsl1)))) /\
                           ((wf_stt R0 R1).(lt) o0 o) /\
                           (sim_knot thsl1 thsr1 tid0
                                     (snd (get_resource tid0 rs_local0))
                                     true true
                                     (b, th_src)
                                     th_tgt
                                     (im_src0, im_tgt0, st_src, st_tgt) o0)))))
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Vis (inl1 (inl1 (inr1 Yield))) ktr_src)
                 (Vis (inl1 (inl1 (inr1 Yield))) ktr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o

    | ksim_yieldL
        tid f_src f_tgt
        sf ktr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: exists im_src0 o0,
            (fair_update im_src im_src0 (prism_fmap inlp (tids_fmap tid (key_set thsl)))) /\
              (_sim_knot thsl thsr tid rs_local true f_tgt
                         (false, ktr_src tt)
                         itr_tgt
                         (im_src0, im_tgt, st_src, st_tgt) o0))
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Vis (inl1 (inl1 (inr1 Yield))) ktr_src)
                 (itr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o

    | ksim_tauL
        tid f_src f_tgt
        sf itr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: _sim_knot thsl thsr tid rs_local true f_tgt
                         (sf, itr_src)
                         itr_tgt
                         (im_src, im_tgt, st_src, st_tgt) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Tau itr_src)
                 (itr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
    | ksim_chooseL
        tid f_src f_tgt
        sf X ktr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: exists x, _sim_knot thsl thsr tid rs_local true f_tgt
                              (sf, ktr_src x)
                              itr_tgt
                              (im_src, im_tgt, st_src, st_tgt) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Vis (inl1 (inl1 (inl1 (Choose X)))) ktr_src)
                 (itr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
    | ksim_rmwL
        tid f_src f_tgt
        sf X rmw ktr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: _sim_knot thsl thsr tid rs_local true f_tgt
                         (sf, ktr_src (snd (rmw st_src) : X))
                         itr_tgt
                         (im_src, im_tgt, fst (rmw st_src), st_tgt) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Vis (inr1 (Rmw rmw)) ktr_src)
                 (itr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
    | ksim_tidL
        tid f_src f_tgt
        sf ktr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: _sim_knot thsl thsr tid rs_local true f_tgt
                         (sf, ktr_src tid)
                         itr_tgt
                         (im_src, im_tgt, st_src, st_tgt) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Vis (inl1 (inl1 (inr1 GetTid))) ktr_src)
                 (itr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
    | ksim_UB
        tid f_src f_tgt
        sf ktr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Vis (inl1 (inl1 (inl1 Undefined))) ktr_src)
                 (itr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
    | ksim_fairL
        tid f_src f_tgt
        sf fm ktr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: exists im_src0,
            (<<FAIR: fair_update im_src im_src0 (prism_fmap inrp fm)>>) /\
              (_sim_knot thsl thsr tid rs_local true f_tgt
                         (sf, ktr_src tt)
                         itr_tgt
                         (im_src0, im_tgt, st_src, st_tgt) o))
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Vis (inl1 (inl1 (inl1 (Fair fm)))) ktr_src)
                 (itr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o

    | ksim_tauR
        tid f_src f_tgt
        sf itr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: _sim_knot thsl thsr tid rs_local f_src true
                         (sf, itr_src)
                         itr_tgt
                         (im_src, im_tgt, st_src, st_tgt) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, itr_src)
                 (Tau itr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
    | ksim_chooseR
        tid f_src f_tgt
        sf itr_src X ktr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: forall x, _sim_knot thsl thsr tid rs_local f_src true
                              (sf, itr_src)
                              (ktr_tgt x)
                              (im_src, im_tgt, st_src, st_tgt) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, itr_src)
                 (Vis (inl1 (inl1 (inl1 (Choose X)))) ktr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
    | ksim_rmwR
        tid f_src f_tgt
        sf itr_src X rmw ktr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: _sim_knot thsl thsr tid rs_local f_src true
                         (sf, itr_src)
                         (ktr_tgt (snd (rmw st_tgt) : X))
                         (im_src, im_tgt, st_src, fst (rmw st_tgt)) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, itr_src)
                 (Vis (inr1 (Rmw rmw)) ktr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
    | ksim_tidR
        tid f_src f_tgt
        sf itr_src ktr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: _sim_knot thsl thsr tid rs_local f_src true
                         (sf, itr_src)
                         (ktr_tgt tid)
                         (im_src, im_tgt, st_src, st_tgt) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, itr_src)
                 (Vis (inl1 (inl1 (inr1 GetTid))) ktr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
    | ksim_fairR
        tid f_src f_tgt
        sf itr_src fm ktr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: forall im_tgt0 (FAIR: fair_update im_tgt im_tgt0 (prism_fmap inrp fm)),
            (_sim_knot thsl thsr tid rs_local f_src true
                       (sf, itr_src)
                       (ktr_tgt tt)
                       (im_src, im_tgt0, st_src, st_tgt) o))
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, itr_src)
                 (Vis (inl1 (inl1 (inl1 (Fair fm)))) ktr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o

    | ksim_observe
        tid f_src f_tgt
        sf fn args ktr_src ktr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: forall ret, sim_knot thsl thsr tid rs_local true true
                               (sf, ktr_src ret)
                               (ktr_tgt ret)
                               (im_src, im_tgt, st_src, st_tgt) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, Vis (inl1 (inl1 (inl1 (Observe fn args)))) ktr_src)
                 (Vis (inl1 (inl1 (inl1 (Observe fn args)))) ktr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o

    | ksim_call
        tid f_src f_tgt
        sf fn args ktr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local f_src f_tgt
                 (sf, (trigger (Call fn args) >>= ktr_src))
                 itr_tgt
                 (im_src, im_tgt, st_src, st_tgt) o

    | ksim_progress
        tid
        sf itr_src itr_tgt
        rs_local
        im_src im_tgt st_src st_tgt o
        (KSIM: sim_knot thsl thsr tid rs_local false false
                        (sf, itr_src)
                        itr_tgt
                        (im_src, im_tgt, st_src, st_tgt) o)
      :
      __sim_knot RR sim_knot _sim_knot thsl thsr tid rs_local true true
                 (sf, itr_src)
                 (itr_tgt)
                 (im_src, im_tgt, st_src, st_tgt) o
  .

  Definition sim_knot R0 R1 (RR: R0 -> R1 -> Prop):
    threads_src2 R0 -> threads_tgt R1 -> thread_id -> local_resources ->
    bool -> bool -> (prod bool (itree srcE R0)) -> (itree tgtE R1) -> kshared -> (wf_stt R0 R1).(T) -> Prop :=
    paco10 (fun r => pind10 (__sim_knot RR r) top10) bot10.

  Lemma __ksim_mon R0 R1 (RR: R0 -> R1 -> Prop):
    forall r r' (LE: r <10= r'), (__sim_knot RR r) <11= (__sim_knot RR r').
  Proof.
    ii. inv PR; try (econs; eauto; fail).
    { econs 2; eauto. i. specialize (KSIM tid0). des; eauto. right.
      esplits; eauto.
      i. specialize (KSIM2 H _ FAIR). des. esplits; eauto.
    }
    { econs 3; eauto. i. specialize (KSIM tid0). des; eauto. right.
      esplits; eauto.
      i. specialize (KSIM1 H _ FAIR). des. esplits; eauto.
      i. specialize (KSIM2 H _ FAIR). des. esplits; eauto.
    }
  Qed.

  Lemma _ksim_mon R0 R1 (RR: R0 -> R1 -> Prop): forall r, monotone10 (__sim_knot RR r).
  Proof.
    ii. inv IN; try (econs; eauto; fail).
    { des. econs; eauto. }
    { des. econs; eauto. }
    { des. econs; eauto. }
  Qed.

  Lemma ksim_mon R0 R1 (RR: R0 -> R1 -> Prop): forall q, monotone10 (fun r => pind10 (__sim_knot RR r) q).
  Proof.
    ii. eapply pind10_mon_gen; eauto.
    ii. eapply __ksim_mon; eauto.
  Qed.

  Local Hint Constructors __sim_knot: core.
  Local Hint Unfold sim_knot: core.
  Local Hint Resolve __ksim_mon: paco.
  Local Hint Resolve _ksim_mon: paco.
  Local Hint Resolve ksim_mon: paco.

  Lemma ksim_reset_prog
        R0 R1 (RR: R0 -> R1 -> Prop)
        ths_src ths_tgt tid rs_local
        ssrc tgt shr o
        ps0 pt0 ps1 pt1
        (KSIM: sim_knot RR ths_src ths_tgt tid rs_local ps1 pt1 ssrc tgt shr o)
        (SRC: ps1 = true -> ps0 = true)
        (TGT: pt1 = true -> pt0 = true)
    :
    sim_knot RR ths_src ths_tgt tid rs_local ps0 pt0 ssrc tgt shr o.
  Proof.
    revert_until RR. pcofix CIH. i.
    move KSIM before CIH. revert_until KSIM. punfold KSIM.
    pattern ths_src, ths_tgt, tid, rs_local, ps1, pt1, ssrc, tgt, shr, o.
    revert ths_src ths_tgt tid rs_local ps1 pt1 ssrc tgt shr o KSIM.
    eapply pind10_acc.
    intros rr DEC IH ths_src ths_tgt tid rs_local ps1 pt1 ssrc tgt shr o KSIM. clear DEC.
    intros ps0 pt0 SRC TGT.
    eapply pind10_unfold in KSIM.
    2:{ eapply _ksim_mon. }
    inv KSIM.

    { pfold. eapply pind10_fold. econs; eauto. }

    { clear rr IH. pfold. eapply pind10_fold. eapply ksim_ret_cont; eauto. i.
      specialize (KSIM0 tid0). des; eauto. right.
      esplits; eauto.
      - i; hexploit KSIM2; clear KSIM2 KSIM3; eauto. i. eapply upaco10_mon_bot; eauto.
      - i; hexploit KSIM3; clear KSIM2 KSIM3; eauto. i. des. esplits; eauto. i. eapply upaco10_mon_bot; eauto.
    }

    { clear rr IH. pfold. eapply pind10_fold. eapply ksim_sync; eauto. i.
      specialize (KSIM0 tid0). des; eauto. right.
      esplits; eauto.
      - i; hexploit KSIM2; clear KSIM2 KSIM3; eauto. i. des. esplits; eauto. i. eapply upaco10_mon_bot; eauto.
      - i; hexploit KSIM3; clear KSIM2 KSIM3; eauto. i. des. esplits; eauto. i. eapply upaco10_mon_bot; eauto.
    }

    { des. pfold. eapply pind10_fold. eapply ksim_yieldL. esplits; eauto. split; ss.
      destruct KSIM1 as [KSIM1 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_tauL. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { des. pfold. eapply pind10_fold. eapply ksim_chooseL. esplits. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_rmwL. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_tidL. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_UB. }

    { des. pfold. eapply pind10_fold. eapply ksim_fairL. esplits; eauto. split; ss.
      destruct KSIM1 as [KSIM1 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_tauR. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_chooseR. i. split; ss. specialize (KSIM0 x).
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_rmwR. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_tidR. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_fairR. i. split; ss. specialize (KSIM0 _ FAIR).
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_observe. i. specialize (KSIM0 ret). pclearbot.
      right; eapply CIH; eauto.
    }

    { pfold. eapply pind10_fold. eapply ksim_call. }

    { hexploit SRC; ss; i; clarify. hexploit TGT; ss; i; clarify.
      pfold. eapply pind10_fold. eapply ksim_progress. pclearbot.
      right; eapply CIH; eauto.
    }

  Qed.

  Lemma ksim_set_prog
        R0 R1 (RR: R0 -> R1 -> Prop)
        ths_src ths_tgt tid rs_local
        ssrc tgt shr o
        (KSIM: sim_knot RR ths_src ths_tgt tid rs_local true true ssrc tgt shr o)
    :
    forall ps pt, sim_knot RR ths_src ths_tgt tid rs_local ps pt ssrc tgt shr o.
  Proof.
    revert_until RR. pcofix CIH. i.
    remember true as ps1 in KSIM at 1. remember true as pt1 in KSIM at 1.
    move KSIM before CIH. revert_until KSIM. punfold KSIM.
    pattern ths_src, ths_tgt, tid, rs_local, ps1, pt1, ssrc, tgt, shr, o.
    revert ths_src ths_tgt tid rs_local ps1 pt1 ssrc tgt shr o KSIM.
    eapply pind10_acc.
    intros rr DEC IH ths_src ths_tgt tid rs_local ps1 pt1 ssrc tgt shr o KSIM. clear DEC.
    intros Eps1 Ept1 ps pt. clarify.
    eapply pind10_unfold in KSIM.
    2:{ eapply _ksim_mon. }
    inv KSIM.

    { pfold. eapply pind10_fold. econs; eauto. }

    { clear rr IH. pfold. eapply pind10_fold. eapply ksim_ret_cont; eauto. i.
      specialize (KSIM0 tid0). des; eauto. right.
      esplits; eauto.
      - i; hexploit KSIM2; clear KSIM2 KSIM3; eauto. i. eapply upaco10_mon_bot; eauto.
      - i; hexploit KSIM3; clear KSIM2 KSIM3; eauto. i. des. esplits; eauto.
        i. eapply upaco10_mon_bot; eauto.
    }

    { clear rr IH. pfold. eapply pind10_fold. eapply ksim_sync; eauto. i.
      specialize (KSIM0 tid0). des; eauto. right.
      esplits; eauto.
      - i; hexploit KSIM2; clear KSIM2 KSIM3; eauto. i. des. esplits; eauto. i. eapply upaco10_mon_bot; eauto.
      - i; hexploit KSIM3; clear KSIM2 KSIM3; eauto. i. des. esplits; eauto. i. eapply upaco10_mon_bot; eauto.
    }

    { des. pfold. eapply pind10_fold. eapply ksim_yieldL. esplits; eauto. split; ss.
      destruct KSIM1 as [KSIM1 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_tauL. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { des. pfold. eapply pind10_fold. eapply ksim_chooseL. esplits. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_rmwL. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_tidL. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_UB. }

    { des. pfold. eapply pind10_fold. eapply ksim_fairL. esplits; eauto. split; ss.
      destruct KSIM1 as [KSIM1 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_tauR. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_chooseR. i. split; ss. specialize (KSIM0 x).
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_rmwR. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_tidR. split; ss.
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_fairR. i. split; ss. specialize (KSIM0 _ FAIR).
      destruct KSIM0 as [KSIM0 IND]. hexploit IH; eauto. i. punfold H.
    }

    { pfold. eapply pind10_fold. eapply ksim_observe. i. specialize (KSIM0 ret). pclearbot.
      right; eapply CIH; eauto.
    }

    { pfold. eapply pind10_fold. eapply ksim_call. }

    { pclearbot. eapply paco10_mon_bot; eauto. eapply ksim_reset_prog. eauto. all: auto. }

  Qed.

End KSIM.
#[export] Hint Constructors __sim_knot: core.
#[export] Hint Unfold sim_knot: core.
#[export] Hint Resolve __ksim_mon: paco.
#[export] Hint Resolve _ksim_mon: paco.
#[export] Hint Resolve ksim_mon: paco.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import RMMHandler.Specs.realm_ns_step.
Require Import RMMHandler.LowSpecs.realm_ns_step.
Require Import RMMHandler.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       user_step_spec
  .

  Lemma realm_ns_step_spec_exists:
    forall habd habd'  labd ret
           (Hspec: realm_ns_step_spec  habd = Some (habd', VZ64 ret))
           (Hrel: relate_RData habd labd),
    exists labd', realm_ns_step_spec0  labd = Some (labd', VZ64 ret) /\ relate_RData habd' labd'.
  Proof.
    intros. unfold realm_ns_step_spec, realm_ns_step_spec0 in *; autounfold in *.
    inv Hrel. repeat simpl_hyp Hspec; inv Hspec;
                (eexists; split; [reflexivity|constructor;reflexivity]).
  Qed.

End Refine.


(** printing |-#    %\vdash_{\#}%    #⊢##     *)
(** printing |-##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing |-##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing |-!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

Set Implicit Arguments.

Require Import TLC.LibLN.
Require Import String.

Require Import Definitions RecordAndInertTypes Decompose.

(** * Abstract Syntax for Constraint Language *)

(** ** Type and Term with constraint-bound variables *)

(** *** Variables
    The variables can either be bound by the core calculus (∀, let),
    or by the constraint (∃ X. C).  *)
Inductive cvar : Set :=
  | cvar_avar : avar -> cvar
  | cvar_cvar : nat -> cvar.

(** *** Type with type variables
    All constructors are the same as those in [typ], except for one additional
    constructor for type variables.
    [ctyp_tvar] represents the reference to a type variable bound by
    the constraint (∃t), represented by de Bruijn indices.  *)
Inductive ctyp : Set :=
  | ctyp_top  : ctyp
  | ctyp_bot  : ctyp
  | ctyp_tvar : nat -> ctyp
  | ctyp_typ : typ -> ctyp
  | ctyp_rcd  : cdec -> ctyp
  | ctyp_and  : ctyp -> ctyp -> ctyp
  | ctyp_sel  : cvar -> typ_label -> ctyp
  | ctyp_bnd  : ctyp -> ctyp
  | ctyp_all  : ctyp -> ctyp -> ctyp
with cdec : Set :=
  | cdec_typ  : typ_label -> ctyp -> ctyp -> cdec
  | cdec_trm  : trm_label -> ctyp -> cdec.

(** *** Terms with variables bound by constraints. *)
Inductive ctrm : Set :=
  | ctrm_var  : cvar -> ctrm
  | ctrm_trm  : trm -> ctrm
  | ctrm_val  : cval -> ctrm
  | ctrm_sel  : cvar -> trm_label -> ctrm
  | ctrm_app  : cvar -> cvar -> ctrm
  | ctrm_let  : ctrm -> ctrm -> ctrm
with cval : Set :=
  | cval_new  : ctyp -> cdefs -> cval
  | cval_lambda : ctyp -> ctrm -> cval
with cdef : Set :=
  | cdef_typ  : typ_label -> ctyp -> cdef
  | cdef_trm  : trm_label -> ctrm -> cdef
with cdefs : Set :=
  | cdefs_nil : cdefs
  | cdefs_cons : cdefs -> cdef -> cdefs.

Scheme ctyp_mut := Induction for ctyp Sort Prop
with   cdec_mut := Induction for cdec Sort Prop.
Combined Scheme ctyp_mutind from ctyp_mut, cdec_mut.

Scheme ctrm_mut  := Induction for ctrm  Sort Prop
with   cval_mut  := Induction for cval Sort Prop
with   cdef_mut  := Induction for cdef  Sort Prop
with   cdefs_mut := Induction for cdefs Sort Prop.
Combined Scheme ctrm_mutind from ctrm_mut, cval_mut, cdef_mut, cdefs_mut.

(** Coercions *)
Coercion ctyp_typ : typ >-> ctyp.
Coercion ctrm_trm : trm >-> ctrm.

(** *** Closeness
    A type or term is closed, if it does not refer to variables bound
    by the existential qualifier of the constraint language.

    In other words, all type variables and term variables are substituted
    to concrete types and variables.  *)
Inductive ctyp_closed : ctyp -> typ -> Prop :=
| ctyp_top_closed : ctyp_closed ctyp_top typ_top
| ctyp_bot_closed : ctyp_closed ctyp_bot typ_bot
| ctyp_typ_closed : forall T,
    ctyp_closed (ctyp_typ T) T
| ctyp_rcd_closed : forall D D',
    cdec_closed D D' ->
    ctyp_closed (ctyp_rcd D) (typ_rcd D')
| ctyp_and_closed : forall T T' U U',
    ctyp_closed T T' ->
    ctyp_closed U U' ->
    ctyp_closed (ctyp_and T U) (typ_and T' U')
| ctyp_sel_closed : forall x T,
    ctyp_closed (ctyp_sel (cvar_avar x) T) (typ_sel x T)
| ctyp_bnd_closed : forall T T',
    ctyp_closed T T' -> ctyp_closed (ctyp_bnd T) (typ_bnd T')
| ctyp_all_closed : forall S S' T T',
    ctyp_closed S S' ->
    ctyp_closed T T' ->
    ctyp_closed (ctyp_all S T) (typ_all S' T')
with cdec_closed : cdec -> dec -> Prop :=
| cdec_typ_closed : forall A S S' T T',
    ctyp_closed S S' ->
    ctyp_closed T T' ->
    cdec_closed (cdec_typ A S T) (dec_typ A S' T')
| cdec_trm_closed : forall a T T',
    ctyp_closed T T' ->
    cdec_closed (cdec_trm a T) (dec_trm a T')
.

Scheme ctyp_closed_mut    := Induction for ctyp_closed Sort Prop
with   cdec_closed_mut    := Induction for cdec_closed Sort Prop.
Combined Scheme ctyp_closed_mutind from ctyp_closed_mut, cdec_closed_mut.

Inductive ctrm_closed : ctrm -> trm -> Prop :=
| ctrm_cvar_closed : forall x,
    ctrm_closed (ctrm_var (cvar_avar x)) (trm_var x)
| ctrm_trm_closed : forall t,
    ctrm_closed (ctrm_trm t) t
| ctrm_val_closed : forall v v',
    cval_closed v v' ->
    ctrm_closed (ctrm_val v) (trm_val v')
| ctrm_sel_closed : forall x T,
    ctrm_closed (ctrm_sel (cvar_avar x) T) (trm_sel x T)
| ctrm_app_closed : forall x y,
    ctrm_closed (ctrm_app (cvar_avar x) (cvar_avar y)) (trm_app x y)
| ctrm_let_closed : forall t t' u u',
    ctrm_closed t t' ->
    ctrm_closed u u' ->
    ctrm_closed (ctrm_let t u) (trm_let t' u')
with cval_closed : cval -> val -> Prop :=
| cval_new_closed : forall T T' ds ds',
    ctyp_closed T T' ->
    cdefs_closed ds ds' ->
    cval_closed (cval_new T ds) (val_new T' ds')
| cval_lambda_closed : forall T T' t t',
    ctyp_closed T T' ->
    ctrm_closed t t' ->
    cval_closed (cval_lambda T t) (val_lambda T' t')
with cdef_closed : cdef -> def -> Prop :=
| cdef_typ_closed : forall A T T',
    ctyp_closed T T' ->
    cdef_closed (cdef_typ A T) (def_typ A T')
| cdef_trm_closed : forall a t t',
    ctrm_closed t t' ->
    cdef_closed (cdef_trm a t) (def_trm a t')
with cdefs_closed : cdefs -> defs -> Prop :=
| cdefs_nil_closed : cdefs_closed cdefs_nil defs_nil
| cdefs_cons_closed : forall d d' ds ds',
    cdef_closed d d' ->
    cdefs_closed ds ds' ->
    cdefs_closed (cdefs_cons ds d) (defs_cons ds' d')
.

Lemma ctyp_closed_unique : forall T T1 T2,
    ctyp_closed T T1 ->
    ctyp_closed T T2 ->
    T1 = T2
with cdec_closed_unique : forall D D1 D2,
    cdec_closed D D1 ->
    cdec_closed D D2 ->
    D1 = D2.
Proof.
  all: introv Hc1 Hc2.
  - induction Hc1; inversion Hc2; subst; auto;
      try (f_equal; apply* cdec_closed_unique);
      try (f_equal; apply* ctyp_closed_unique).
  - induction Hc1; inversion Hc2; subst; auto;
      try (f_equal; apply* ctyp_closed_unique).
Qed.

Lemma ctrm_closed_unique : forall t t1 t2,
    ctrm_closed t t1 ->
    ctrm_closed t t2 ->
    t1 = t2
with cval_closed_unique : forall v v1 v2,
    cval_closed v v1 ->
    cval_closed v v2 ->
    v1 = v2
with cdef_closed_unique : forall d d1 d2,
    cdef_closed d d1 ->
    cdef_closed d d2 ->
    d1 = d2
with cdefs_closed_unique : forall ds ds1 ds2,
    cdefs_closed ds ds1 ->
    cdefs_closed ds ds2 ->
    ds1 = ds2.
Proof.
  all: introv Hc1 Hc2; induction Hc1;
    inversion Hc2; subst; auto;
    try (f_equal; eauto);
    try apply* ctyp_closed_unique.
Qed.

(** ** Constraint Language *)
Inductive constr : Set :=
(** ⊤ *)
| constr_true : constr
(** ⊥ *)
| constr_false : constr
(** C ⋏ D *)
| constr_and : constr -> constr -> constr
(** C ⋎ D *)
| constr_or : constr -> constr -> constr
(** ∃X. C *)
| constr_exists_typ : constr -> constr
(** ∃x. C *)
| constr_exists_var : constr -> constr
(** S <: T *)
| constr_sub : ctyp -> ctyp -> constr
(** t : T *)
| constr_typ : ctrm -> ctyp -> constr
.

(** - true constraint *)
Notation "⊤" := constr_true.
(** - false constraint *)
Notation "⊥" := constr_false.
(** - and constraint *)
Notation "C '⋏' D" := (constr_and C D) (at level 30).
(** - or constraint *)
Notation "C '⋎' D" := (constr_or C D) (at level 30).
(** - type existence constraint *)
Notation "'∃t' C" := (constr_exists_typ C) (at level 30).
(** - variable existence constraint *)
Notation "'∃v' C" := (constr_exists_var C) (at level 30).
(** - typing constraint *)
Notation "x '⦂' T" := (constr_typ x T) (at level 29).
(** - subtyping constraint *)
Notation "S '<⦂' T" := (constr_sub S T) (at level 29).

(** Syntax sugars *)
(** - type equality constraint *)
Notation "S '=⦂=' T" := (S <⦂ T ⋏ T <⦂ S) (at level 29).

(** ** Opening *)

Fixpoint open_rec_ctyp_typ (k : nat) (t : typ) (T : ctyp) : ctyp :=
  match T with
  | ctyp_top => ctyp_top
  | ctyp_bot => ctyp_bot
  | ctyp_tvar i => If k = i then ctyp_typ t else ctyp_tvar i
  | ctyp_typ u => ctyp_typ u
  | ctyp_rcd D => ctyp_rcd (open_rec_cdec_typ k t D)
  | ctyp_and T U => ctyp_and (open_rec_ctyp_typ k t T) (open_rec_ctyp_typ k t U)
  | ctyp_sel x T => ctyp_sel x T
  | ctyp_bnd T => ctyp_bnd (open_rec_ctyp_typ k t T)
  | ctyp_all T U => ctyp_all (open_rec_ctyp_typ k t T) (open_rec_ctyp_typ k t U)
  end
with open_rec_cdec_typ (k : nat) (t : typ) (D : cdec) : cdec :=
  match D with
  | cdec_typ A T U => cdec_typ A (open_rec_ctyp_typ k t T) (open_rec_ctyp_typ k t U)
  | cdec_trm a T => cdec_trm a (open_rec_ctyp_typ k t T)
  end.

Definition open_rec_cvar (k : nat) (u : var) (v : cvar) : cvar :=
  match v with
  | cvar_avar x => cvar_avar x
  | cvar_cvar i => If k = i then cvar_avar (avar_f u) else cvar_cvar i
  end.

Fixpoint open_rec_ctyp_var (k : nat) (u : var) (T : ctyp) : ctyp :=
  match T with
  | ctyp_top => ctyp_top
  | ctyp_bot => ctyp_bot
  | ctyp_tvar i => ctyp_tvar i
  | ctyp_typ u => ctyp_typ u
  | ctyp_rcd D => ctyp_rcd (open_rec_cdec_var k u D)
  | ctyp_and T U => ctyp_and (open_rec_ctyp_var k u T) (open_rec_ctyp_var k u U)
  | ctyp_sel x T => ctyp_sel (open_rec_cvar k u x) T
  | ctyp_bnd T => ctyp_bnd (open_rec_ctyp_var k u T)
  | ctyp_all T U => ctyp_all (open_rec_ctyp_var k u T) (open_rec_ctyp_var k u U)
  end
with open_rec_cdec_var (k : nat) (u : var) (D : cdec) : cdec :=
  match D with
  | cdec_typ A T U => cdec_typ A (open_rec_ctyp_var k u T) (open_rec_ctyp_var k u U)
  | cdec_trm a T => cdec_trm a (open_rec_ctyp_var k u T)
  end.

Fixpoint open_rec_ctrm_typ (k : nat) (t : typ) (u : ctrm) : ctrm :=
  match u with
  | ctrm_var x => ctrm_var x
  | ctrm_trm t => ctrm_trm t
  | ctrm_val v => ctrm_val (open_rec_cval_typ k t v)
  | ctrm_sel x T => ctrm_sel x T
  | ctrm_app x y => ctrm_app x y
  | ctrm_let t1 t2 => ctrm_let (open_rec_ctrm_typ k t t1) (open_rec_ctrm_typ k t t2)
  end
with open_rec_cval_typ (k : nat) (t : typ) (v : cval) : cval :=
  match v with
  | cval_new T ds => cval_new (open_rec_ctyp_typ k t T) (open_rec_cdefs_typ k t ds)
  | cval_lambda T u => cval_lambda (open_rec_ctyp_typ k t T) (open_rec_ctrm_typ k t u)
  end
with open_rec_cdef_typ (k : nat) (t : typ) (d : cdef) : cdef :=
  match d with
  | cdef_typ A T => cdef_typ A (open_rec_ctyp_typ k t T)
  | cdef_trm a u => cdef_trm a (open_rec_ctrm_typ k t u)
  end
with open_rec_cdefs_typ (k : nat) (t : typ) (ds : cdefs) : cdefs :=
  match ds with
  | cdefs_nil => cdefs_nil
  | cdefs_cons ds d => cdefs_cons (open_rec_cdefs_typ k t ds) (open_rec_cdef_typ k t d)
  end.

Fixpoint open_rec_ctrm_var (k : nat) (u : var) (t : ctrm) : ctrm :=
  match t with
  | ctrm_var x => ctrm_var (open_rec_cvar k u x)
  | ctrm_trm t => ctrm_trm t
  | ctrm_val v => ctrm_val (open_rec_cval_var k u v)
  | ctrm_sel x T => ctrm_sel (open_rec_cvar k u x) T
  | ctrm_app x y => ctrm_app (open_rec_cvar k u x) (open_rec_cvar k u y)
  | ctrm_let t1 t2 => ctrm_let (open_rec_ctrm_var k u t1) (open_rec_ctrm_var k u t2)
  end
with open_rec_cval_var (k : nat) (u : var) (v : cval) : cval :=
  match v with
  | cval_new T ds => cval_new (open_rec_ctyp_var k u T) (open_rec_cdefs_var k u ds)
  | cval_lambda T t => cval_lambda (open_rec_ctyp_var k u T) (open_rec_ctrm_var k u t)
  end
with open_rec_cdef_var (k : nat) (u : var) (d : cdef) : cdef :=
  match d with
  | cdef_typ A T => cdef_typ A (open_rec_ctyp_var k u T)
  | cdef_trm a t => cdef_trm a (open_rec_ctrm_var k u t)
  end
with open_rec_cdefs_var (k : nat) (u : var) (ds : cdefs) : cdefs :=
  match ds with
  | cdefs_nil => cdefs_nil
  | cdefs_cons ds d => cdefs_cons (open_rec_cdefs_var k u ds) (open_rec_cdef_var k u d)
  end.

Fixpoint open_rec_constr_typ (k : nat) (T : typ) (C : constr) : constr :=
  match C with
  | constr_true => constr_true
  | constr_false => constr_false
  | constr_and C1 C2 => constr_and (open_rec_constr_typ k T C1) (open_rec_constr_typ k T C2)
  | constr_or C1 C2 => constr_or (open_rec_constr_typ k T C1) (open_rec_constr_typ k T C2)
  | constr_exists_typ C => constr_exists_typ (open_rec_constr_typ (S k) T C)
  | constr_exists_var C => constr_exists_var (open_rec_constr_typ k T C)
  | constr_sub T1 T2 => constr_sub (open_rec_ctyp_typ k T T1) (open_rec_ctyp_typ k T T2)
  | constr_typ t T0 => constr_typ (open_rec_ctrm_typ k T t) (open_rec_ctyp_typ k T T0)
  end.

Fixpoint open_rec_constr_var (k : nat) (u : var) (C : constr) : constr :=
  match C with
  | constr_true => constr_true
  | constr_false => constr_false
  | constr_and C1 C2 => constr_and (open_rec_constr_var k u C1) (open_rec_constr_var k u C2)
  | constr_or C1 C2 => constr_or (open_rec_constr_var k u C1) (open_rec_constr_var k u C2)
  | constr_exists_typ C => constr_exists_typ (open_rec_constr_var k u C)
  | constr_exists_var C => constr_exists_var (open_rec_constr_var (S k) u C)
  | constr_sub T1 T2 => constr_sub (open_rec_ctyp_var k u T1) (open_rec_ctyp_var k u T2)
  | constr_typ t T0 => constr_typ (open_rec_ctrm_var k u t) (open_rec_ctyp_var k u T0)
  end.

Definition open_ctyp_typ (S : typ) (T : ctyp) : ctyp := open_rec_ctyp_typ 0 S T.
Definition open_cdec_typ (S : typ) (D : cdec) : cdec := open_rec_cdec_typ 0 S D.
Definition open_ctyp_var (u : var) (T : ctyp) : ctyp := open_rec_ctyp_var 0 u T.
Definition open_cdec_var (u : var) (D : cdec) : cdec := open_rec_cdec_var 0 u D.
Definition open_constr_typ (T : typ) (C : constr) : constr := open_rec_constr_typ 0 T C.
Definition open_constr_var (u : var) (C : constr) : constr := open_rec_constr_var 0 u C.

Notation "C '^^t' T" := (open_constr_typ T C) (at level 30).
Notation "C '^^v' u" := (open_constr_var u C) (at level 30).

(** ** Lemmas on openning and closed types *)

Ltac invsc H := inversion H; subst; clear H.
Ltac invs H := inversion H; subst.

Ltac open_closed_eq_aux :=
  match goal with
  | |- (?P ?L) = (?P ?R) =>
      assert (L = R) as ?H by eauto
  | |- (?P ?L1 ?L2) = (?P ?R1 ?R2) =>
      assert (L1 = R1) as ?H by eauto
  end.

Ltac simpl_open_ctyp :=
  unfold open_ctyp_typ, open_cdec_typ, open_ctyp_var, open_cdec_var; simpl.

Ltac solve_cong_eq :=
  solve [
    f_equal; eauto
  ].

Lemma open_closed_ctyp_typ_unchanged : forall S T T',
    ctyp_closed T T' ->
    open_ctyp_typ S T = T
with open_closed_cdec_typ_unchanged : forall S D D',
    cdec_closed D D' ->
    open_cdec_typ S D = D.
Proof.
  all: introv Hc; induction Hc; auto; simpl_open_ctyp; try solve_cong_eq.
Qed.

Lemma open_closed_ctyp_var_unchanged : forall S T T',
    ctyp_closed T T' ->
    open_ctyp_var S T = T
with open_closed_cdec_var_unchanged : forall S D D',
    cdec_closed D D' ->
    open_cdec_var S D = D.
Proof.
  all: introv Hc; induction Hc; auto; simpl_open_ctyp; try solve_cong_eq.
Qed.

Definition is_closed_ctyp (T : ctyp) := exists T', ctyp_closed T T'.

Lemma open_closed_ctyp_typ_unchanged' : forall S T,
    is_closed_ctyp T ->
    open_ctyp_typ S T = T.
Proof.
  introv [T' Hc]. apply* open_closed_ctyp_typ_unchanged.
Qed.

Lemma open_closed_ctyp_var_unchanged' : forall u T,
    is_closed_ctyp T ->
    open_ctyp_var u T = T.
Proof.
  introv [T' Hc]. apply* open_closed_ctyp_var_unchanged.
Qed.

(** * Constraint Interpretation *)

Reserved Notation "G '⊧' C" (at level 40).

Inductive satisfy_constr : ctx -> constr -> Prop :=

| sat_true : forall G,
    G ⊧ ⊤

| sat_and : forall G C1 C2,
    G ⊧ C1 ->
    G ⊧ C2 ->
    G ⊧ C1 ⋏ C2

| sat_or1 : forall G C1 C2,
    G ⊧ C1 ->
    G ⊧ C1 ⋎ C2

| sat_or2 : forall G C1 C2,
    G ⊧ C2 ->
    G ⊧ C1 ⋎ C2

| sat_exists_typ : forall G T C,
    G ⊧ C ^^t T ->
    G ⊧ (∃t C)

| sat_exists_var : forall G u C,
    G ⊧ C ^^v u ->
    G ⊧ (∃v C)

| sat_typ : forall G t t' T T',
    ctrm_closed t t' ->
    ctyp_closed T T' ->
    G ⊢ t' : T' ->
    G ⊧ t ⦂ T

| sat_sub : forall G S S' T T',
    ctyp_closed S S' ->
    ctyp_closed T T' ->
    G ⊢ S' <: T' ->
    G ⊧ S <⦂ T

where "G '⊧' C" := (satisfy_constr G C).

Hint Constructors satisfy_constr constr.

(** * Constraint Entailment *)

(** ** Definition of entailment *)
Definition constr_entail (C1 C2 : constr) :=
  forall G,
    inert G ->
    satisfy_constr G C1 -> satisfy_constr G C2.

Notation "C '⊩' D" := (constr_entail C D) (at level 50).

(** ** Tactics *)

Ltac introe := introv H0 H.

Ltac inv_sat :=
  match goal with
  | H : _ ⊧ (_ _) |- _ => idtac H; inversion H; subst; clear H
  | H : _ ⊧ (_ _ _) |- _ => idtac H; inversion H; subst; clear H
  | H : _ ⊧ ⊥ |- _ => idtac H; inversion H; subst; clear H
  end.

Ltac inv_sat_all := repeat inv_sat.

Ltac inv_closed :=
  match goal with
  | H : ctyp_closed (_ _) _ |- _ => idtac H; inversion H; subst; clear H
  | H : ctyp_closed (_ _ _) _ |- _ => idtac H; inversion H; subst; clear H
  | H : ctrm_closed (_ _) _ |- _ => idtac H; inversion H; subst; clear H
  | H : ctrm_closed (_ _ _) _ |- _ => idtac H; inversion H; subst; clear H
  end.

Ltac inv_closed_all := repeat inv_closed.

Ltac simpl_open_constr :=
  unfold open_constr_typ, open_constr_var in *; simpl in *; try case_if.

Ltac solve_open_closed_ctyp_eq T0 T :=
  match goal with
  | Hc : is_closed_ctyp T |- _ =>
      try replace (open_rec_ctyp_typ 0 T0 T) with T in * by
        (symmetry; apply* open_closed_ctyp_typ_unchanged');
      try replace (open_rec_ctyp_var 0 T0 T) with T in * by
        (symmetry; apply* open_closed_ctyp_var_unchanged')
  | Hc : ctyp_closed T _ |- _ =>
      idtac Hc;
      try replace (open_rec_ctyp_typ 0 T0 T) with T in * by
        (symmetry; apply* open_closed_ctyp_typ_unchanged);
      try replace (open_rec_ctyp_var 0 T0 T) with T in * by
        (symmetry; apply* open_closed_ctyp_var_unchanged)
  end.

Ltac solve_ctyp_closed_unique T1 T2 :=
  match goal with
  | |- _ => replace T1 with T2 in * by apply* ctyp_closed_unique
  end.

Ltac solve_ctrm_closed_unique t1 t2 :=
  match goal with
  | |- _ => replace t1 with t2 in * by apply* ctrm_closed_unique
  end.

Ltac solve_trivial_sub :=
  match goal with
  | H : ?G ⊢ ?S <: ?T |- ?G ⊧ (ctyp_typ ?S) <⦂ (ctyp_typ ?T) =>
    idtac G; idtac S; idtac T;
    apply sat_sub with (S' := S) (T' := T); try assumption; try apply ctyp_typ_closed
  end.

(** ** Entailment Laws *)

(** ∀ C, ⊥ ⊩ C
    From false follows everything. *)
Theorem ent_absurd : forall C,
    ⊥ ⊩ C.
Proof.
  introe. inversion H.
Qed.

(** ∀ C, C ⊩ ⊤ *)
Theorem ent_tautology : forall C,
    C ⊩ ⊤.
Proof. introe. eauto. Qed.

Lemma ent_refl : forall C,
    C ⊩ C.
Proof.
  introe. auto.
Qed.

(** If C1 ⊩ C2 and C2 ⊩ C3, then C1 ⊩ C3. *)
Theorem ent_trans : forall C1 C2 C3,
    C1 ⊩ C2 ->
    C2 ⊩ C3 ->
    C1 ⊩ C3.
Proof.
  introv H12 H23.
  introe.
  eauto.
Qed.

Theorem ent_cong_and : forall C C' D,
    C ⊩ C' ->
    C ⋏ D ⊩ C' ⋏ D.
Proof.
  introv He. introe. inversion H; subst.
  eauto.
Qed.

Theorem ent_and_comm : forall C D,
    C ⋏ D ⊩ D ⋏ C.
Proof.
  introe. inv_sat. eauto.
Qed.

Theorem ent_and_left : forall C D,
    C ⋏ D ⊩ C.
Proof. introe. inversion H; subst. eauto. Qed.

Theorem ent_and_right : forall C D,
    C ⋏ D ⊩ D.
Proof. introe. inversion H; subst. eauto. Qed.

Theorem ent_and_intro : forall C D,
    C ⊩ D ->
    C ⊩ C ⋏ D.
Proof.
  introv Hcd. introe.
  constructor*.
Qed.

Lemma ent_and_assoc : forall C1 C2 C3,
    (C1 ⋏ C2) ⋏ C3 ⊩ C1 ⋏ (C2 ⋏ C3).
Proof.
  introe. inv_sat. inv_sat. eauto.
Qed.

Lemma ent_or_comm : forall C D,
    C ⋎ D ⊩ D ⋎ C.
Proof.
  introe. inv_sat; eauto.
Qed.

Lemma ent_or_assoc : forall C1 C2 C3,
    (C1 ⋎ C2) ⋎ C3 ⊩ C1 ⋎ (C2 ⋎ C3).
Proof.
  introe. inv_sat; try inv_sat. all: eauto.
Qed.

Lemma ent_or_true : forall C,
    ⊤ ⊩ C ⋎ ⊤.
Proof.
  introe. eauto.
Qed.

Lemma ent_or_false : forall C,
    C ⋎ ⊥ ⊩ C.
Proof.
  introe. inv_sat; eauto. inv_sat.
Qed.

Lemma ent_or_dist_and : forall C D1 D2,
    C ⋎ (D1 ⋏ D2) ⊩ (C ⋎ D1) ⋏ (C ⋎ D2).
Proof.
  introe. inv_sat; try inv_sat; eauto.
Qed.

Lemma ent_and_dist_or : forall C D1 D2,
    C ⋏ (D1 ⋎ D2) ⊩ (C ⋏ D1) ⋎ (C ⋏ D2).
Proof.
  introe. inv_sat; try inv_sat; eauto.
Qed.

(** If U is fresh for S and T, then
    ∃ U. (S <: U ⋏ U <: T) ⊩ S <: T
 *)
Theorem ent_sub_trans : forall S T,
    is_closed_ctyp S -> is_closed_ctyp T ->
    ∃t (S <⦂ (ctyp_tvar 0) ⋏ (ctyp_tvar 0) <⦂ T) ⊩ S <⦂ T.
Proof.
  introv Hs Ht.
  introe. inv_sat.
  simpl_open_constr. inv_sat.
  solve_open_closed_ctyp_eq T0 T.
  solve_open_closed_ctyp_eq T0 S.
  inv_sat_all. apply sat_sub with (S' := S'0) (T' := T'); auto.
  solve_ctyp_closed_unique S' T'0.
  eauto.
Qed.

(** If C ⊩ D, then ∃ x. C ⊩ ∃ x. D *)
Lemma ent_cong_exists_v : forall C D,
    (forall u C' D',
        C ^^v u = C' ->
        D ^^v u = D' ->
        C' ⊩ D') ->
    ∃v C ⊩ ∃v D.
Proof.
  introv Hent. introe. inv_sat.
  apply sat_exists_var with (u := u).
  apply* Hent.
Qed.

(** x: T ⊩ ∃y. y: T *)
Lemma ent_exists_v_intro : forall x T,
    ctrm_var (cvar_avar (avar_f x)) ⦂ T ⊩ ∃v ctrm_var (cvar_cvar 0) ⦂ T.
Proof.
  introv. introe.
  inv_sat.
  inversion H3; subst.
  apply sat_exists_var with (u := x).
  simpl_open_constr. apply* sat_typ.
  solve_open_closed_ctyp_eq x T. auto.
Qed.

Lemma ent_exists_v_intro' : forall x T,
    ctrm_trm (trm_var (avar_f x)) ⦂ T ⊩ ∃v ctrm_var (cvar_cvar 0) ⦂ T.
Proof.
  introe. inv_sat. inv_closed.
  apply sat_exists_var with (u := x). simpl_open_constr.
  solve_open_closed_ctyp_eq x T. eapply sat_typ.
  apply ctrm_cvar_closed.
  match goal with
  | H : ctyp_closed T _ |- _ => exact H
  end.
  auto.
Qed.

(** ∃x. (x: {A:S1..T1} ⋏ x: {A:S2..T2}) ⊩ S1 <: T2 ⋏ S2 <: T1 *)
Lemma ent_bound_sub : forall A S1 T1 S2 T2,
    ∃v (ctrm_var (cvar_cvar 0) ⦂ typ_rcd (dec_typ A S1 T1) ⋏
        ctrm_var (cvar_cvar 0) ⦂ typ_rcd (dec_typ A S2 T2)) ⊩
    S1 <⦂ T2 ⋏ S2 <⦂ T1.
Proof.
  introv. introe.
  inv_sat. simpl_open_constr.
  inv_sat_all.
  solve_ctrm_closed_unique t' t'0.
  inv_closed_all.
  assert (G ⊢ S1 <: T2 /\ G ⊢ S2 <: T1) as [Hs1 Hs2] by apply* typ_bounds_subtyping.
  apply* sat_and; solve_trivial_sub.
Qed.

(** x: S ⋏ S <: T ⊩ x: T *)
Lemma ent_typ_subsume : forall x S T,
    trm_var (avar_f x) ⦂ S ⋏ S <⦂ T ⊩ trm_var (avar_f x) ⦂ T.
Proof.
  introe. inv_sat_all. inversion H3; subst.
  apply* sat_typ.
  solve_ctyp_closed_unique S' T'0. eauto.
Qed.

(** U1 /\ U2 <: {A: S..T} ⊩ U1 <: {A: S..T} \/ U2 <: {A: S..T}
 *)
Theorem ent_sub_and_rcd_or : forall U1 U2 A S T,
    typ_and U1 U2 <⦂ typ_rcd (dec_typ A S T) ⊩
        U1 <⦂ typ_rcd (dec_typ A S T) ⋎ U2 <⦂ typ_rcd (dec_typ A S T).
Proof.
  introv. introe.
  inv_sat. inv_closed_all.
  match goal with
  | H : G ⊢ _ <: _ |- _ =>
    apply invert_subtyp_and1_rcd in H as [?H1 | ?H2]; try assumption;
      try (apply sat_or1; solve_trivial_sub);
      try (apply sat_or2; solve_trivial_sub)
  end.
Qed.

(** {A: S1..T1} <: {A: S2..T2} ⊩ S2 <: S1 ⋏ T1 <: T2 *)
Theorem ent_inv_subtyp_typ : forall A S1 T1 S2 T2,
    typ_rcd (dec_typ A S1 T1) <⦂ typ_rcd (dec_typ A S2 T2) ⊩
        S2 <⦂ S1 ⋏ T1 <⦂ T2.
Proof.
  introv. introe. inv_sat. inv_closed_all.
  match goal with
  | H : G ⊢ _ <: _ |- _ =>
    apply invert_subtyp_typ in H as [Hs1 Hs2]; try assumption
  end.
  constructor; solve_trivial_sub.
Qed.

(** If A ≠ B,
    then {A:S1..T1} <: {B:S2..T2} ⊩ ⊥  *)
Theorem ent_subtyp_typ_label_neq_false : forall A S1 T1 B S2 T2,
    A <> B ->
    typ_rcd (dec_typ A S1 T1) <⦂ typ_rcd (dec_typ B S2 T2) ⊩ ⊥.
Proof.
  introv Hne. introe. inv_sat. inv_closed_all.
  apply invert_subtyp_typ_label_neq_false in H6; try assumption.
  contradiction.
Qed.

(** S <: T ∧ U ⊩ S <: T ⋏ S <: U *)
Lemma ent_sub_and_and : forall S T U,
    S <⦂ typ_and T U ⊩ S <⦂ T ⋏ S <⦂ U.
Proof.
  introe. inv_sat. inv_closed.
  assert (G ⊢ S' <: T /\ G ⊢ S' <: U) as [Hs1 Hs2] by apply* invert_subtyp_and2.
  apply* sat_and; eapply sat_sub with (S' := S');
    try assumption;
    try apply ctyp_typ_closed;
    try assumption.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                 Xavier Leroy, INRIA Paris                           *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Recognition of combined operations, addressing modes and conditions
  during the [CSE] phase. *)

Require Import FunInd.
Require Import Coqlib.
Require Import Integers Values Memory.
Require Import Op RTL CSEdomain.
Require Import CombineOp.

Section COMBINE.

Variable ge: genv.
Variable sp: val.
Variable m: mem.
Variable get: valnum -> option rhs.
Variable valu: valnum -> val.
Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v).

Lemma get_op_sound:
  forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v).
Proof.
  intros. exploit get_sound; eauto. intros REV; inv REV; auto.
Qed.

Ltac UseGetSound :=
  match goal with
  | [ H: get _ = Some _ |- _ ] =>
      let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv)
  end.

Lemma combine_compimm_ne_0_sound:
  forall x cond args,
  combine_compimm_ne_0 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero).
Proof.
  intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
  (* of and *)
  UseGetSound. rewrite <- H.
  destruct v; simpl; auto.
Qed.

Lemma combine_compimm_eq_0_sound:
  forall x cond args,
  combine_compimm_eq_0 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero).
Proof.
  intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  rewrite eval_negate_condition.
  destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
  (* of and *)
  UseGetSound. rewrite <- H. destruct v; auto.
Qed.

Lemma combine_compimm_eq_1_sound:
  forall x cond args,
  combine_compimm_eq_1 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one).
Proof.
  intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_ne_1_sound:
  forall x cond args,
  combine_compimm_ne_1 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one).
Proof.
  intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  rewrite eval_negate_condition.
  destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Theorem combine_cond_sound:
  forall cond args cond' args',
  combine_cond get cond args = Some(cond', args') ->
  eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m.
Proof.
  intros. functional inversion H; subst.
  (* compimm ne zero *)
  simpl; eapply combine_compimm_ne_0_sound; eauto.
  (* compimm ne one *)
  simpl; eapply combine_compimm_ne_1_sound; eauto.
  (* compimm eq zero *)
  simpl; eapply combine_compimm_eq_0_sound; eauto.
  (* compimm eq one *)
  simpl; eapply combine_compimm_eq_1_sound; eauto.
  (* compuimm ne zero *)
  simpl; eapply combine_compimm_ne_0_sound; eauto.
  (* compuimm ne one *)
  simpl; eapply combine_compimm_ne_1_sound; eauto.
  (* compuimm eq zero *)
  simpl; eapply combine_compimm_eq_0_sound; eauto.
  (* compuimm eq one *)
  simpl; eapply combine_compimm_eq_1_sound; eauto.
Qed.

Theorem combine_addr_32_sound:
  forall addr args addr' args',
  combine_addr_32 get addr args = Some(addr', args') ->
  eval_addressing32 ge sp addr' (map valu args') = eval_addressing32 ge sp addr (map valu args).
Proof.
  intros. functional inversion H; subst.
  (* indexed - lea *)
  UseGetSound. simpl. unfold offset_addressing in H7. destruct (addressing_valid (offset_addressing_total a n)); inv H7.
  eapply eval_offset_addressing_total_32; eauto.
Qed.

Theorem combine_addr_64_sound:
  forall addr args addr' args',
  combine_addr_64 get addr args = Some(addr', args') ->
  eval_addressing64 ge sp addr' (map valu args') = eval_addressing64 ge sp addr (map valu args).
Proof.
  intros. functional inversion H; subst.
  (* indexed - leal *)
  UseGetSound. simpl. unfold offset_addressing in H7. destruct (addressing_valid (offset_addressing_total a n)); inv H7.
  eapply eval_offset_addressing_total_64; eauto.
Qed.

Theorem combine_addr_sound:
  forall addr args addr' args',
  combine_addr get addr args = Some(addr', args') ->
  eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args).
Proof.
  unfold combine_addr, eval_addressing; intros; destruct Archi.ptr64.
  apply combine_addr_64_sound; auto.
  apply combine_addr_32_sound; auto.
Qed.

Theorem combine_op_sound:
  forall op args op' args',
  combine_op get op args = Some(op', args') ->
  eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m.
Proof.
  intros. functional inversion H; subst.
(* lea-lea *)
  simpl. eapply combine_addr_32_sound; eauto.
(* leal-leal *)
  simpl. eapply combine_addr_64_sound; eauto.
(* andimm - andimm *)
  UseGetSound; simpl. rewrite <- H0. rewrite Val.and_assoc. auto.
(* orimm - orimm *)
  UseGetSound; simpl. rewrite <- H0. rewrite Val.or_assoc. auto.
(* xorimm - xorimm *)
  UseGetSound; simpl. rewrite <- H0. rewrite Val.xor_assoc. auto.
(* andimm - andimm *)
  UseGetSound; simpl. rewrite <- H0. rewrite Val.andl_assoc. auto.
(* orimm - orimm *)
  UseGetSound; simpl. rewrite <- H0. rewrite Val.orl_assoc. auto.
(* xorimm - xorimm *)
  UseGetSound; simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto.
(* cmp *)
  simpl. decEq; decEq. eapply combine_cond_sound; eauto.
Qed.

End COMBINE.


(*
Record representing the AM Monad state structure.

Author:  Adam Petz, ampetz@ku.edu
*)

Require Import Maps EqbPair ConcreteEvidence.

Require Import List.
Import ListNotations.

Definition asp_map := MapC (Plc * ASP_ID) ASP_ID.
Definition sig_map := MapC Plc ASP_ID.

(* Specific AM monad state *)
Record AM_St : Type := mkAM_St
                         { am_nonceMap : MapC nat BS;
                           am_nonceId : nat;
                           st_aspmap : asp_map;
                           st_sigmap : sig_map;
                           (*am_pl : Plc *)(*;
                           checked : list nat*) }.

Definition empty_amst :=
  mkAM_St [] 0 [] [].


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

Inductive tree :=
| LEAF: forall i, 0 <= i <= Int.max_signed -> tree
| NODE: tree -> tree -> tree.

Fixpoint treerep (t: tree) (p: val) : mpred :=
  match t with
  | LEAF i _ => !! (p = Vint (Int.repr (i+i+1))) && emp
  | NODE t1 t2 => EX p1:val, EX p2: val,
               data_at Tsh (Tstruct _tree noattr) (p1,p2) p
              * treerep t1 p1 * treerep t2 p2
  end.

Definition POINTER_BOUNDARY : Z := 1024.

Definition valid_int_or_ptr (x: val) :=
 match x with
 | Vint i => Int.testbit i 0 = true
              \/ Int.unsigned i < POINTER_BOUNDARY
 | Vptr b z => Ptrofs.testbit z 0 = false
 | _ => False
 end.

Lemma valid_int_or_ptr_ii1:
 forall i, valid_int_or_ptr (Vint (Int.repr (i + i + 1))).
Proof.
intros.
simpl.
left.
rewrite Int.unsigned_repr_eq.
rewrite Zodd_mod.
apply Zeq_is_eq_bool.
replace (i+i) with (2*i)%Z by lia.
rewrite <- Zmod_div_mod; try lia.
rewrite Z.mul_comm, Z.add_comm.
rewrite Z_mod_plus_full.
reflexivity.
compute; reflexivity.
exists (Z.div Int.modulus 2).
reflexivity.
Qed.

Lemma valid_int_or_ptr_i2:
 forall i, 0 <= i < POINTER_BOUNDARY ->
   valid_int_or_ptr (Vint (Int.repr i)).
Proof.
intros.
simpl.
right.
unfold POINTER_BOUNDARY in *.
rewrite Int.unsigned_repr by rep_lia.
rep_lia.
Qed.

Lemma field_compatible_valid_int_or_ptr:
  forall p,
  field_compatible (Tstruct _tree noattr) [] p ->
  valid_int_or_ptr p.
Proof.
intros.
destruct H as [H1 [_ [_ [H2 _]]]].
destruct p; try contradiction.
clear - H2; simpl in *.
    rewrite Zodd_even_bool.
    apply negb_false_iff.
    apply Zeven_bool_iff.
    inv H2.
    1: inv H.
    inv H1.
    specialize (H4 _left _ _ eq_refl eq_refl).
    inv H4.
    inv H.
    simpl in H0.
    destruct H0 as [j H].
    rewrite Z.add_0_r in H.
    rewrite H; clear.
    replace (j*4)%Z with (2*(2*j))%Z by lia.
    apply Zeven_2p.
Qed.

Lemma treerep_local_facts:
  forall t p,
   treerep t p |--
   !! (valid_int_or_ptr p).
Proof.
intros.
destruct t; simpl.
entailer!.
apply valid_int_or_ptr_ii1.
Intros p1 p2.
entailer!.
apply field_compatible_valid_int_or_ptr; auto.
Qed.

#[export] Hint Resolve treerep_local_facts : saturate_local.

Definition test_int_or_ptr_spec :=
 DECLARE _test_int_or_ptr
 WITH x : val
 PRE [ int_or_ptr_type ]
   PROP(valid_int_or_ptr x) PARAMS (x) SEP()
 POST [ tint ]
   PROP()
   RETURN (Vint (Int.repr (match x with
                    | Vint _ => 1
                    | _ => 0
                    end)))
   SEP().

Definition int_or_ptr_to_int_spec :=
 DECLARE _int_or_ptr_to_int
 WITH x : val
 PRE [ int_or_ptr_type ]
   PROP(is_int I32 Signed x) PARAMS (x) SEP()
 POST [ tint ]
   PROP() RETURN (x) SEP().

Definition int_or_ptr_to_ptr_spec :=
 DECLARE _int_or_ptr_to_ptr
 WITH x : val
 PRE [ int_or_ptr_type ]
   PROP(isptr x) PARAMS (x) SEP()
 POST [ tptr tvoid ]
   PROP() RETURN (x) SEP().

Definition int_to_int_or_ptr_spec :=
 DECLARE _int_to_int_or_ptr
 WITH x : val
 PRE [ tint ]
   PROP(valid_int_or_ptr x) PARAMS(x) SEP()
 POST [ int_or_ptr_type ]
   PROP() RETURN(x) SEP().

Definition ptr_to_int_or_ptr_spec :=
 DECLARE _ptr_to_int_or_ptr
 WITH x : val
 PRE [ tptr tvoid ]
   PROP(valid_int_or_ptr x) PARAMS(x) SEP()
 POST [ int_or_ptr_type ]
   PROP() RETURN(x) SEP().

Definition makenode_spec :=
 DECLARE _makenode
  WITH p: val, q: val
  PRE [ int_or_ptr_type, int_or_ptr_type ]
    PROP() PARAMS(p; q) SEP()
  POST [ tptr (Tstruct _tree noattr) ]
    EX r:val,
    PROP() RETURN (r)
    SEP (data_at Tsh (Tstruct _tree noattr) (p,q) r).

Definition copytree_spec :=
 DECLARE _copytree
  WITH t: tree, p : val
  PRE  [ int_or_ptr_type ]
    PROP() PARAMS (p) SEP (treerep t p)
  POST [ int_or_ptr_type ]
    EX v:val,
    PROP() RETURN (v)
    SEP (treerep t p; treerep t v).

Definition Gprog : funspecs :=
    ltac:(with_library prog [
    test_int_or_ptr_spec;
    int_or_ptr_to_int_spec;
    int_or_ptr_to_ptr_spec;
    int_to_int_or_ptr_spec;
    ptr_to_int_or_ptr_spec;
    makenode_spec; copytree_spec
  ]).

Lemma body_copytree: semax_body Vprog Gprog f_copytree copytree_spec.
Proof.
  start_function.
  assert_PROP (valid_int_or_ptr p) by entailer!.
  destruct t.
* (* LEAF *)
 unfold treerep.
 Intros. subst p.
 forward_call (Vint (Int.repr (i+i+1))).
 forward_if.
 - (* then clause *)
   forward. simpl.
   Exists (Vint (Int.repr(i+i+1))).
   entailer!.
 - (* else clause *)
  inv H0.
* (* NODE *)
  unfold treerep; fold treerep.
  rename p into t.
  Intros p q.
  forward_call t.
  assert_PROP (isptr t) by entailer!.
  destruct t; try contradiction. clear H0.
  forward_if.
  - (* then clause *)
    contradiction.
  - (* else clause *)
   clear H0. simpl in H.
   forward_call (Vptr b i).
   forward.
     entailer!.
     destruct p; try contradiction; apply I.
   forward_call (t1,p).
   Intros p1.
   deadvars.
   forward.
   forward.
    entailer!.
     destruct q; try contradiction; apply I.
   forward_call (t2,q).
   Intros p2.
   forward.
   deadvars.
  assert_PROP (p1 <> Vundef).
  entailer!.
  assert_PROP (p2 <> Vundef).
  entailer!.
   forward_call (p1,p2).
  Intros r.
  assert_PROP (valid_int_or_ptr r). {
    entailer!.
    apply field_compatible_valid_int_or_ptr; auto.
  }
  forward_call r.
  forward. simpl.
  Exists r p q p1 p2.
  entailer!.
Qed.