(** * EIP20 Token Implementation *)
(**
  This file contains correctness proofs of the EIP20 token implementation.
*)
From Coq Require Import ZArith_base.
From Coq Require Import List. Import ListNotations.
From Coq Require Import Lia.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Utils Require Import Automation.
From ConCert.Utils Require Import Extras.
From ConCert.Examples.EIP20 Require Import EIP20Token.

(** * Properties *)
Section Theories.
  Context {BaseTypes : ChainBase}.
  Open Scope N_scope.
  Open Scope bool.

  (** ** EIP20 functions not payable *)

  (** [receive] only returns Some if the sender amount is zero *)
  Lemma EIP20_not_payable : forall prev_state new_state chain ctx msg new_acts,
    receive chain ctx prev_state msg = Ok (new_state, new_acts) ->
      ((ctx_amount ctx) <= 0)%Z.
  Proof.
    intros * receive_some.
    unfold receive in receive_some.
    destruct_match eqn:amount in receive_some.
    - (* case: ctx_amount > 0 *)
      discriminate.
    - (* case: ctx_amount <= 0 *)
      now rewrite Z.gtb_ltb, Z.ltb_ge in amount.
  Qed.

  (** Lemma for simplifying the [receive] function by eliminating the case
      where sender amount is larger than zero *)
  Lemma receive_not_payable : forall prev_state new_state chain ctx msg new_acts,
    receive chain ctx prev_state (Some msg) = Ok (new_state, new_acts) ->
      match msg with
      | transfer to amount => (try_transfer (ctx_from ctx) to amount prev_state) >>= (fun new_state : State => Ok (new_state, []))
      | transfer_from from to amount =>
          (try_transfer_from (ctx_from ctx) from to amount prev_state) >>= (fun new_state : State => Ok (new_state, []))
      | approve delegate amount =>
          (try_approve (ctx_from ctx) delegate amount prev_state) >>= (fun new_state : State => Ok (new_state, []))
      end = Ok (new_state, new_acts).
  Proof.
    intros * receive_some.
    apply EIP20_not_payable in receive_some as amount_zero.
    unfold receive in receive_some.
    rewrite <- Z.ltb_ge, <- Z.gtb_ltb in amount_zero.
    now rewrite amount_zero in receive_some.
  Qed.

  (** ** EIP20 functions produce no acts *)

  (** [receive] never produces any [new_acts] *)
  Lemma EIP20_no_acts : forall prev_state new_state chain ctx msg new_acts,
    receive chain ctx prev_state msg = Ok (new_state, new_acts) ->
      new_acts = [].
  Proof.
    intros * receive_some.
    unfold receive, option_map in receive_some.
    repeat (destruct_match in receive_some; cbn in *); easy.
  Qed.

  Lemma receive_no_acts : forall prev_state new_state chain ctx msg new_acts,
    receive chain ctx prev_state (Some msg) = Ok (new_state, new_acts) ->
      receive chain ctx prev_state (Some msg) = Ok (new_state, []).
  Proof.
    intros.
    now erewrite <- EIP20_no_acts.
  Qed.

  (** Default entrypoint always fail *)
  Lemma default_none : forall prev_state chain ctx,
    receive chain ctx prev_state None = Err default_error.
  Proof.
    intros.
    unfold receive.
    now destruct_match.
  Qed.

  (* begin hide *)
  (* FMap partial alter is FMap add *)
  Lemma add_is_partial_alter_plus : forall (account : Address) amount (balances : FMap Address N) (f : N -> N),
    FMap.partial_alter (fun balance : option N => Some (with_default 0 balance + amount)) account balances =
    FMap.add account (with_default 0 (FMap.find account balances) + amount) balances.
  Proof.
    intros.
    now apply fin_maps.partial_alter_ext.
  Qed.

  Lemma increment_balanace_is_partial_alter_plus : forall (addr : Address) amount (m : FMap Address N),
    increment_balance m addr amount =
    FMap.partial_alter (fun balance : option N => Some (with_default 0 balance + amount)) addr m.
  Proof.
    intros.
    unfold increment_balance, AddressMap.add, AddressMap.find.
    rewrite add_is_partial_alter_plus by auto.
    destruct_match eqn:addr_in_map;
      now setoid_rewrite addr_in_map.
  Qed.

  (* Tactic to simplify proof steps *)
  Ltac eip_simpl :=
    match goal with
    | H : receive _ _ _ (Some _) = Ok (_, _) |- _ =>
      apply receive_no_acts, receive_not_payable in H; cbn in H
    | |- receive _ _ _ (Some _) = Ok (_, _) =>
      apply receive_no_acts, receive_not_payable; cbn
    | H : context[try_transfer] |- _ => unfold try_transfer in H
    | H : context[try_transfer_from] |- _ => unfold try_transfer_from in H
    | H : context[try_approve] |- _ => unfold try_approve in H
    | H : context[error] |- _ => unfold error in H
    | |- context[try_transfer] => unfold try_transfer
    | |- context[try_transfer_from] => unfold try_transfer_from
    | |- context[try_approve] => unfold try_approve
    | |- context[error] => unfold error
    end.

  Ltac address_map_convert :=
    match goal with
    | H : context [ AddressMap.find _ _ ] |- _ => rewrite AddressMap_find_convertible in H
    | H : context [ AddressMap.add _ _ _ ] |- _ => rewrite AddressMap_add_convertible in H
    | H : context [ increment_balance _ _ _ ] |- _ => rewrite increment_balanace_is_partial_alter_plus in H
    | |- context [ AddressMap.find _ _ ] => rewrite AddressMap_find_convertible
    | |- context [ AddressMap.add _ _ _ ] => rewrite AddressMap_add_convertible
    | |- context [ increment_balance _ _ _ ] => rewrite increment_balanace_is_partial_alter_plus
    end.

  Tactic Notation "contract_simpl" :=
    repeat (
      try eip_simpl;
      try address_map_convert;
      try contract_simpl_step @receive @init).

  Ltac FMap_simpl_step :=
    match goal with
      | |- context [ FMap.find ?x (FMap.add ?x _ _) ] => setoid_rewrite FMap.find_add
      | H : FMap.find ?t ?m = Some _ |- FMap.find ?t ?m = Some _ => cbn; rewrite H; f_equal; lia
      | H : ?x <> ?y |- context [ FMap.find ?x (FMap.add ?y _ _) ] => setoid_rewrite FMap.find_add_ne; eauto
      | H : ?y <> ?x |- context [ FMap.find ?x (FMap.add ?y _ _) ] => setoid_rewrite FMap.find_add_ne; eauto
      | H : FMap.find ?x _ = Some _ |- context [ FMap.elements (FMap.add ?x _ _) ] => setoid_rewrite FMap.elements_add_existing; eauto
      | |- context [ FMap.add ?x _ (FMap.add ?x _ _) ] => setoid_rewrite FMap.add_add
      | H : FMap.find ?x _ = None |- context [ FMap.elements (FMap.add ?x _ _) ] => setoid_rewrite FMap.elements_add; eauto
      | |- context [ FMap.remove ?x (FMap.add ?x _ _) ] => rewrite fin_maps.delete_insert_delete
      | |- context [ FMap.find ?x (FMap.partial_alter _ ?x _) ] => setoid_rewrite FMap.find_partial_alter
      | H : ?x' <> ?x |- context [ FMap.find ?x' (FMap.partial_alter _ ?x _) ] => setoid_rewrite FMap.find_partial_alter_ne; auto
      | H : ?x <> ?x' |- context [ FMap.find ?x' (FMap.partial_alter _ ?x _) ] => setoid_rewrite FMap.find_partial_alter_ne
      | H : context [ AddressMap.find _ _ ] |- _ => rewrite AddressMap_find_convertible in H
      | H : context [ AddressMap.add _ _ _ ] |- _ => rewrite AddressMap_add_convertible in H
      | H : context [ increment_balance _ _ _ ] |- _ => rewrite increment_balanace_is_partial_alter_plus in H
      | |- context [ AddressMap.find _ _ ] => rewrite AddressMap_find_convertible
      | |- context [ AddressMap.add _ _ _ ] => rewrite AddressMap_add_convertible
      | |- context [ increment_balance _ _ _ ] => rewrite increment_balanace_is_partial_alter_plus
    end.

  Tactic Notation "FMap_simpl" := repeat (FMap_simpl_step; cbn).

  Ltac destruct_message :=
    repeat match goal with
    | msg : option Msg |- _ => destruct msg
    | msg : Msg |- _ => destruct msg
    | H : Blockchain.receive _ _ _ _ None = Ok _ |- _ => now contract_simpl
    | H : receive _ _ _ None = Ok _ |- _ => now contract_simpl
    end.

  (* sumN function *)
  (* sumN of balances is the same after transfer changes if sender has enough balance *)
  Lemma sumN_FMap_add_sub : forall from to amount (balances : FMap Address N),
    amount <= with_default 0 (FMap.find from balances) ->
      (sumN (fun '(_, v) => v) (FMap.elements balances)) =
      (sumN(fun '(_, v) => v)
        (FMap.elements
            (FMap.partial_alter (fun balance : option N => Some (with_default 0 balance + amount)) to
              (FMap.add from (with_default 0 (FMap.find from balances) - amount) balances)))).
  Proof.
    intros from to amount balances from_enough_balance.
    rewrite add_is_partial_alter_plus; auto.
    edestruct (address_eqb from to) eqn:from_to_eq;
      destruct FMap.find eqn:from_prev;
      destruct_address_eq; try discriminate; subst; cbn in *;
      repeat match goal with
      | H : _ <= 0 |- _ => apply N.lt_eq_cases in H as [H | H]; try lia; subst
      | |- context [ with_default _ (FMap.find to balances) ] => destruct (FMap.find to balances) eqn:to_prev; cbn
      | |- context [ FMap.find ?x (FMap.add ?x _ _) ] => rewrite FMap.find_add
      | H : FMap.find ?t ?m = Some _ |- FMap.find ?t ?m = Some _ => cbn; rewrite H; f_equal; lia
      | H : ?x <> ?y |- context [ FMap.find ?x (FMap.add ?y _ _) ] => rewrite FMap.find_add_ne; eauto
      | H : ?y <> ?x |- context [ FMap.find ?x (FMap.add ?y _ _) ] => rewrite FMap.find_add_ne; eauto
      | H : FMap.find ?x _ = Some _ |- context [ FMap.elements (FMap.add ?x _ _) ] => rewrite FMap.elements_add_existing; eauto
      | |- context [ FMap.add ?x _ (FMap.add ?x _ _) ] => rewrite FMap.add_add
      | H : FMap.find ?x _ = None |- context [ FMap.elements (FMap.add ?x _ _) ] => rewrite FMap.elements_add; eauto
      | |- context [ FMap.remove ?x (FMap.add ?x _ _) ] => rewrite fin_maps.delete_insert_delete
      | H : FMap.find ?x ?m = Some _ |- context [ sumN _ ((_, _) :: FMap.elements (FMap.remove ?x ?m)) ] => rewrite fin_maps.map_to_list_delete; auto
      | H : FMap.find ?x _ = Some ?n |- context [ sumN _ ((?x, ?n) :: FMap.elements (FMap.remove ?x _)) ] => rewrite fin_maps.map_to_list_delete; auto
      | H : FMap.find ?x _ = Some ?n |- context [ sumN _ ((?x, ?n) :: (_, _) :: FMap.elements (FMap.remove ?x _)) ] => rewrite sumN_swap, fin_maps.map_to_list_delete; auto
      | |- context [ _ + 0 ] => rewrite N.add_0_r
      | |- context [ 0 + _ ] => rewrite N.add_0_l
      | |- context [ sumN _ ((?t, ?n + ?m) :: _) ] => erewrite sumN_split with (x := (t, n)) (y := (_, m)) by lia
      | |- context [ sumN _ ((_, ?n) :: (_, ?m - ?n) :: _) ] => erewrite <- sumN_split with (z := (_, n + m - n)) by lia
    end.
    Unshelve. eauto.
  Qed.

  (* end hide *)

  (** ** Expected behaviour of EIP20 functions *)
  Definition transfer_balance_update_correct old_state new_state from to tokens :=
    let get_balance addr state := with_default 0 (FMap.find addr state.(balances)) in
    let from_balance_before := get_balance from old_state in
    let to_balance_before := get_balance to old_state in
    let from_balance_after := get_balance from new_state in
    let to_balance_after := get_balance to new_state in
    (** if the transfer is a self-transfer, balances should remain unchained *)
    if address_eqb from to
    then
      (from_balance_before =? from_balance_after) &&
      (to_balance_before =? to_balance_after)
    else
      (from_balance_before =? from_balance_after + tokens) &&
      (to_balance_before + tokens =? to_balance_after).

  Definition transfer_from_allowances_update_correct (old_state new_state : State) (from delegate : Address) (tokens : TokenValue) :=
    let delegate_allowance_before := get_allowance old_state from delegate in
    let delegate_allowance_after := get_allowance new_state from delegate in
      delegate_allowance_before =? delegate_allowance_after + tokens.

  Definition approve_allowance_update_correct (new_state : State) (from delegate : Address) (tokens : TokenValue) :=
    let delegate_allowance_after := get_allowance new_state from delegate in
      delegate_allowance_after =? tokens.

  (** ** Transfer correct *)

  (** [try_transfer] correctly moves [amount] from [sender] to [to] *)
  Lemma try_transfer_balance_correct : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
    transfer_balance_update_correct prev_state new_state ctx.(ctx_from) to amount = true.
  Proof.
    intros * receive_some.
    unfold transfer_balance_update_correct.
    contract_simpl.
    rename H0 into sender_enough_balance.
    apply N.ltb_ge in sender_enough_balance.
    destruct_address_eq; destruct (FMap.find (ctx_from ctx) (balances prev_state)) eqn:from_prev;
      try congruence; subst; try (rewrite from_prev || setoid_rewrite from_prev);
      clear from_prev new_acts chain; cbn in *.
      - (* case: from = to && find from = Some n && amount <= n *)
        FMap_simpl.
        now rewrite N.sub_add, N.eqb_refl.
      - (* case: from = to && find from = None && amount = 0 *)
        apply N.lt_eq_cases in sender_enough_balance as []; [lia | subst].
        now FMap_simpl.
      - (* case: from <> to && find from = Some n && amount <= n *)
        FMap_simpl.
        rewrite N.sub_add; auto.
        now rewrite !N.eqb_refl.
      - (* case: from <> to && find from = None && amount = 0 *)
        apply N.lt_eq_cases in sender_enough_balance as []; [lia | subst].
        FMap_simpl.
        apply N.eqb_refl.
  Qed.

  (** [try_transfer] does not change the total supply of tokens *)
  Lemma try_transfer_preserves_total_supply : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
      (total_supply prev_state) = (total_supply new_state).
  Proof.
    intros * receive_some.
    now contract_simpl.
  Qed.

  (** [try_transfer] does not change allowances *)
  Lemma try_transfer_preserves_allowances : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
      (allowances prev_state) = (allowances new_state).
  Proof.
    intros * receive_some.
    now contract_simpl.
  Qed.

  (** [try_transfer] only modifies the [sender] and [to] balances *)
  Lemma try_transfer_preserves_other_balances : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
      forall account, account <> (ctx_from ctx) -> account <> to ->
        FMap.find account (balances prev_state) = FMap.find account (balances new_state).
  Proof.
    intros * receive_some account account_not_sender account_not_receiver.
    contract_simpl.
    cbn.
    FMap_simpl.
  Qed.

  (** If the requirements are met then receive on transfer msg must succeed and
      if receive on transfer msg succeeds then requirements must hold *)
  Lemma try_transfer_is_some : forall state chain ctx to amount,
    (ctx_amount ctx <= 0)%Z /\
    amount <= with_default 0 (FMap.find (ctx_from ctx) (balances state))
      <-> isOk (receive chain ctx state (Some (transfer to amount))) = true.
  Proof.
    intros.
    split.
    - intros (amount_positive & sender_enough_balance);
      contract_simpl; destruct_match eqn:amount_from; auto.
      + now propify.
      + rewrite <- N.ltb_ge in sender_enough_balance.
        now setoid_rewrite sender_enough_balance.
    - intros receive_some.
      contract_simpl.
      destruct_match eqn:amount_positive in receive_some;
        try now inversion receive_some.
      destruct_match eqn:amount_from in receive_some.
      + destruct_match eqn:amount_from_ in amount_from.
        * discriminate.
        * now propify.
      + now propify.
  Qed.

  (** ** Transfer_from correct *)

  (** [try_transfer_from] correctly updates balance and allowance *)
  Lemma try_transfer_from_balance_correct : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
    transfer_balance_update_correct prev_state new_state from to amount = true /\
    transfer_from_allowances_update_correct prev_state new_state from ctx.(ctx_from) amount = true.
  Proof.
    intros * receive_some.
    unfold transfer_balance_update_correct,
      transfer_from_allowances_update_correct,
      get_allowance.
    contract_simpl.
    rename H0 into from_allowances.
    rename H1 into sender_allowance.
    rewrite result_of_option_eq_some in from_allowances.
    rewrite result_of_option_eq_some in sender_allowance.
    propify.
    destruct H2 as (sender_enough_allowance & from_enough_balance).
    split.
      + (* proof of balance updated correct *)
      destruct_address_eq;
        destruct (FMap.find from (balances prev_state)) eqn:from_bal_prev;
        subst; try (rewrite from_bal_prev || setoid_rewrite from_bal_prev); cbn in *.
        * (* case: from = to && find from = Some n && amount <= n *)
          FMap_simpl.
          now rewrite N.sub_add, N.eqb_refl.
        * (* case: from = to && find from = None && amount = 0 *)
          apply N.lt_eq_cases in from_enough_balance as []; [lia | subst].
          now FMap_simpl.
        * (* case: from <> to && find from = Some n && amount <= n *)
          FMap_simpl.
          rewrite N.sub_add by auto.
          now rewrite ?N.eqb_refl.
        * (* case: from <> to && find from = None && amount = 0 *)
          apply N.lt_eq_cases in from_enough_balance as []; [lia | subst].
          FMap_simpl.
          apply N.eqb_refl.
      + (* proof of allowances updated correct *)
        rewrite from_allowances.
        cbn.
        setoid_rewrite sender_allowance.
        FMap_simpl.
        now rewrite N.sub_add.
  Qed.

  (** [try_transfer_from] does not change total supply of tokens *)
  Lemma try_transfer_from_preserves_total_supply : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      (total_supply prev_state) = (total_supply new_state).
  Proof.
    intros * receive_some.
    now contract_simpl.
  Qed.

  (** [try_transfer_from] only changes [from] and [to] balances *)
  Lemma try_transfer_from_preserves_other_balances : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      forall account, account <> from -> account <> to ->
        FMap.find account (balances prev_state) = FMap.find account (balances new_state).
  Proof.
    intros * receive_some account account_not_from account_not_to.
    contract_simpl.
    cbn.
    FMap_simpl.
  Qed.

  (** [try_transfer_from] only changes allowance map of [from] *)
  Lemma try_transfer_from_preserves_other_allowances : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      forall account, account <> from ->
        FMap.find account (allowances prev_state) = FMap.find account (allowances new_state).
  Proof.
    intros * receive_some account account_not_from.
    contract_simpl.
    cbn.
    FMap_simpl.
  Qed.

  (** [try_transfer_from] only changes allowance of [sender] *)
  Lemma try_transfer_from_preserves_other_allowance : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      forall account, account <> (ctx_from ctx) ->
        get_allowance prev_state from account = get_allowance new_state from account.
  Proof.
    intros * receive_some account account_not_sender.
    unfold get_allowance.
    contract_simpl.
    rewrite result_of_option_eq_some in H0.
    rewrite result_of_option_eq_some in H1.
    rewrite H0.
    cbn.
    FMap_simpl.
  Qed.

  Set Keyed Unification.

  (** If the requirements are met then receive on transfer_from msg must succeed and
      if receive on transfer_from msg succeeds then requirements must hold *)
  Lemma try_transfer_from_is_some : forall state chain ctx from to amount,
    let get_allowance_ account := FMap.find account (with_default (@FMap.empty (FMap Address TokenValue) _) (FMap.find from (allowances state))) in
    (ctx_amount ctx >? 0)%Z = false ->
    isSome (FMap.find from (allowances state)) = true
    /\ isSome (get_allowance_ (ctx_from ctx)) = true
    /\ amount <= with_default 0 (FMap.find from (balances state))
    /\ amount <= with_default 0 (get_allowance_ (ctx_from ctx))
      <-> isOk (receive chain ctx state (Some (transfer_from from to amount))) = true.
  Proof.
    intros * sender_amount_zero.
    split; contract_simpl; rewrite sender_amount_zero in *;
      unfold get_allowance_; clear get_allowance_; cbn.
    - intros (from_allowances_some &
              sender_allowance &
              from_enough_balance%N.ltb_ge &
              sender_enough_allowance%N.ltb_ge).
      destruct_match eqn:receive_some; cbn in *; auto.
      destruct_match eqn:allowances_ctx in receive_some;
        try (apply result_of_option_eq_none in allowances_ctx; now rewrite allowances_ctx in from_allowances_some).
      rewrite result_of_option_eq_some in allowances_ctx.
      rewrite allowances_ctx in *.
      clear from_allowances_some allowances_ctx.
      cbn in *.
      destruct_match eqn:allowance_ctx in receive_some;
        try (apply result_of_option_eq_none in allowance_ctx; now rewrite allowance_ctx in sender_allowance).
      rewrite result_of_option_eq_some in allowance_ctx.
      rewrite allowance_ctx in *.
      clear allowance_ctx sender_allowance.
      destruct_match eqn:amount_from in receive_some; try discriminate.
      rewrite from_enough_balance in amount_from.
      now rewrite sender_enough_allowance in amount_from.
    - intros receive_some.
      destruct_match eqn:H in receive_some; try discriminate.
      destruct_match eqn:allowances_ctx in H; try discriminate.
      destruct_match eqn:allowance_ctx in H; try discriminate.
      destruct_match eqn:amount_from in H; try discriminate.
      cbn in *.
      propify.
      rewrite result_of_option_eq_some in allowances_ctx.
      rewrite result_of_option_eq_some in allowance_ctx.
      now rewrite allowances_ctx, allowance_ctx.
  Qed.

  (** ** Approve correct *)

  (** [try_approve] correctly replaces allowance *)
  Lemma try_approve_allowance_correct : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
    approve_allowance_update_correct new_state ctx.(ctx_from) delegate amount = true.
  Proof.
    intros * receive_some.
    unfold approve_allowance_update_correct, get_allowance.
    contract_simpl.
    destruct_match eqn:from_allowance in H;
      inversion H; cbn;
      FMap_simpl; apply N.eqb_refl.
  Qed.

  (** [try_approve] does not change total supply of tokens *)
  Lemma try_approve_preserves_total_supply : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      (total_supply prev_state) = (total_supply new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    destruct_match in H;
      now inversion H.
  Qed.

  (** [try_approve] does not change balances *)
  Lemma try_approve_preserves_balances : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      (balances prev_state) = (balances new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    destruct_match in H;
      now inversion H.
  Qed.

  (** [try_approve] does not change allowances map of other addresses *)
  Lemma try_approve_preserves_other_allowances : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      forall account, account <> (ctx_from ctx) ->
        FMap.find account (allowances prev_state) = FMap.find account (allowances new_state).
  Proof.
    intros * receive_some account account_not_sender.
    contract_simpl.
    destruct_match in H;
      inversion H;
      cbn; FMap_simpl.
  Qed.

  (** [try_approve] does not change allowance of other addresses *)
  Lemma try_approve_preserves_other_allowance : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      forall account, account <> delegate ->
        get_allowance prev_state (ctx_from ctx) account = get_allowance new_state (ctx_from ctx) account.
  Proof.
    intros * receive_some account account_not_delegate.
    contract_simpl.
    unfold get_allowance.
    destruct_match eqn:allowances_from in H;
      inversion H;
      cbn; FMap_simpl.
  Qed.

  (** If the requirements are met then receive on approve msg must succeed and
      if receive on approve msg succeeds then requirements must hold *)
  Lemma try_approve_is_some : forall state chain ctx delegate amount,
    (ctx_amount ctx >? 0)%Z = false <-> isOk (receive chain ctx state (Some (approve delegate amount))) = true.
  Proof.
    split; contract_simpl.
    - intros sender_amount_zero.
      rewrite sender_amount_zero.
      destruct_match eqn:H; auto.
      destruct_match in H; discriminate.
    - intros receive_some.
      now destruct_match in receive_some.
  Qed.

  (** ** EIP20 functions preserve sum of balances *)

  (** Sum of all balances remain the same after processing transfer msg *)
  Lemma try_transfer_preserves_balances_sum : forall prev_state new_state chain ctx to amount new_acts,
    receive chain ctx prev_state (Some (transfer to amount)) = Ok (new_state, new_acts) ->
      (sum_balances prev_state) = (sum_balances new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    propify.
    unfold sum_balances. cbn.
    now apply sumN_FMap_add_sub.
  Qed.

  (** Sum of all balances remain the same after processing transfer_from msg *)
  Lemma try_transfer_from_preserves_balances_sum : forall prev_state new_state chain ctx from to amount new_acts,
    receive chain ctx prev_state (Some (transfer_from from to amount)) = Ok (new_state, new_acts) ->
      (sum_balances prev_state) = (sum_balances new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    propify.
    unfold sum_balances. cbn.
    now apply sumN_FMap_add_sub.
  Qed.

  (** Sum of all balances remain the same after approve transfer msg *)
  Lemma try_approve_preserves_balances_sum : forall prev_state new_state chain ctx delegate amount new_acts,
    receive chain ctx prev_state (Some (approve delegate amount)) = Ok (new_state, new_acts) ->
      (sum_balances prev_state) = (sum_balances new_state).
  Proof.
    intros * receive_some.
    contract_simpl.
    destruct_match in H;
      now inversion H.
  Qed.

  (** ** Contract never produces any actions *)
  Lemma outgoing_acts_nil : forall (bstate : ChainState) (caddr : Address),
    reachable bstate ->
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    outgoing_acts bstate caddr = [].
  Proof.
    intros * reach deployed.
    apply (lift_outgoing_acts_nil contract); eauto.
    intros.
    unfold Blockchain.receive in *.
    now eapply EIP20_no_acts.
  Qed.

  (** ** Total supply always equals initial supply *)
  Lemma total_supply_eq_init_supply bstate caddr (trace : ChainTrace empty_state bstate) :
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    exists deploy_info cstate,
      deployment_info _ trace caddr = Some deploy_info
      /\ contract_state bstate caddr = Some cstate
      /\ let init_supply := init_amount deploy_info.(deployment_setup) in
        init_supply = total_supply cstate.
  Proof.
    apply (lift_dep_info_contract_state_prop contract); intros *.
    - intros init_some.
      now inversion init_some.
    - intros IH receive_some.
      destruct_message.
      + now apply try_transfer_preserves_total_supply in receive_some.
      + now apply try_transfer_from_preserves_total_supply in receive_some.
      + now apply try_approve_preserves_total_supply in receive_some.
  Qed.

  (** ** Sum of balances always equals total supply *)
  Lemma sum_balances_eq_total_supply bstate caddr :
    reachable bstate ->
    env_contracts bstate caddr = Some (contract : WeakContract) ->
    exists cstate,
      contract_state bstate caddr = Some cstate
      /\ (total_supply cstate) = (sum_balances cstate).
  Proof.
    intros.
    apply (lift_contract_state_prop contract); eauto; intros *.
    - intros init_some.
      inversion_clear init_some.
      unfold sum_balances.
      setoid_rewrite FMap.elements_add; auto.
      setoid_rewrite FMap.elements_empty. cbn. lia.
    - intros IH receive_some.
      unfold Blockchain.receive in *.
      cbn in *.
      destruct_message.
      + now erewrite try_transfer_preserves_balances_sum,
          try_transfer_preserves_total_supply in IH.
      + now erewrite try_transfer_from_preserves_balances_sum,
          try_transfer_from_preserves_total_supply in IH.
      + now erewrite try_approve_preserves_balances_sum,
          try_approve_preserves_total_supply in IH.
  Qed.

End Theories.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                          Pierre CASTERAN                             *)
(*                            2003 -2006                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Require Export basics.
Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

Section props.
 Variables A W I J: Set.

(* some inversion lemmas *)

Lemma access_res:forall  decI decJ n (r:resource W) (rp
:rule_pattern I J) (Gamma':context I J A W)(A1: Form I J A),
access decI decJ rp n (res r A1) =(Some Gamma',true) ->
 {i:nat |rp=(pvar i)}.

 intros  decI decJ n r rp; case rp.
 simpl in |- *.
 intro n0.
 intros.
 exists n0.
 auto.
 simpl in |- *.
 intros.
 discriminate H.
 simpl in |- *.
 intros.
 discriminate H.
Defined.

Lemma access_com_none:forall (rp1 rp2:rule_pattern I J) decI decJ n i
                      (Gamma:context I J A W),
                   access decI decJ (pcomma i rp1 rp2) n Gamma=(None, true) ->
                      {Gamma1:context I J A W&{Gamma2:context  I J A W|
                       Gamma=(Comma i Gamma1 Gamma2)/\
                     (access decI decJ rp2 n Gamma2=(None,true))/\
                      (access  decI decJ rp1 n Gamma1=(None, true))}}.

 simpl in |- *.
 intros  rp1 rp2 decI decJ n i Gamma; case Gamma.
 intros.
 discriminate H.
 intro i0; case (decI i0 i).
 intro R; subst; intros c c0.
 intros.
 exists c; exists c0; generalize H; clear H.
 case (access decI decJ rp1 n c).
 intros o b0; case o.
 intro c1; case (access decI decJ rp2 n c0).
 intro o0; case o0.
 intros.
 discriminate H.
 intro b1; case b1.
 intro H; discriminate H.
 intro H; discriminate H.
 case b0.
 tauto.
 intro H; discriminate H.
 intros.
 discriminate H.
 intros; discriminate H.
Qed.

Lemma access_com_some:forall (rp1 rp2:rule_pattern I J) decI decJ n b
 i (Gamma Gamma':context I J A W),
          access decI decJ (pcomma i rp1 rp2) n Gamma=((Some Gamma'), b) ->
         {Gamma1:context I J A W&{Gamma2:context I J A W|
           Gamma=(Comma i Gamma1 Gamma2)/\
         (((access decI decJ rp1 n Gamma1=((Some Gamma'),b))/\
                      (access  decI decJ rp2 n Gamma2=(None, true))) \/
                     ((access decI decJ rp2 n Gamma2=((Some Gamma'),b))/\
                      (access  decI decJ rp1 n Gamma1=(None, true))))}}.
 simpl in |- *.
 intros rp1 rp2 decI decJ n b i Gamma Gamma'; case Gamma.
 intros.
 discriminate H.
 intro i0; case (decI i0 i).
 intro R; subst; intros c c0.
 intros.
 exists c; exists c0; generalize H; clear H.
 case (access decI decJ rp1 n c).
 intros o b0; case o.
 intro c1; case (access decI decJ rp2 n c0).
 intro o0; case o0.
 intros.
 discriminate H.
 intro b1; case b1.
 intros; tauto.
 intro H; discriminate H.
 case b0.
 tauto.
 intro H; discriminate H.
 intros.
 discriminate H.
 intros.
 discriminate H.
Qed.

Lemma access_Com_some:forall (rp:rule_pattern I J) decI decJ n
 i (Gamma1 Gamma2 Gamma':context I J A W),
                   access decI decJ rp n (Comma i Gamma1 Gamma2)=
                     ((Some Gamma'), true) ->
                      {rp1:rule_pattern I J &{rp2:rule_pattern I J&
                     {H: {(access decI decJ rp1 n Gamma1=((Some Gamma'),true))/\
                      (access  decI decJ rp2 n Gamma2=(None, true))} +
                     {(access decI decJ rp2 n Gamma2=((Some Gamma'),true))/\
                      (access  decI decJ rp1 n Gamma1=(None,true))} |
                       rp=pcomma i rp1 rp2}}}
                  +{i:nat|rp=pvar i}.
 intros.
 generalize H; clear H.
 case rp.
 intros; right.
 exists n0; auto.
 intros i0 r r0.
 intro H0.
 cut
 ({access decI decJ r n Gamma1 = (Some Gamma', true) /\
   access decI decJ r0 n Gamma2 = (None, true)} +
  {access decI decJ r0 n Gamma2 = (Some Gamma', true) /\
  access decI decJ r n Gamma1 = (None, true)}).
 intro H.
 left.
 exists r; exists r0; exists H.
 generalize H0.
 simpl in |- *.
 case (decI i i0).
 intros; subst; auto.
 intros.
 discriminate H1.
 generalize H0.
 simpl in |- *.
 case (decI i i0).
 case (access decI decJ r n Gamma1).
 intro o; case o.
 case (access decI decJ r0 n Gamma2).
 intro o0; case o0.
 intros.
 discriminate H1.
 intro b; case b.
 intros.
 injection H1; intros; subst.
 left.
 tauto.
 intros.
 discriminate H1.
 intro b; case b.
 intros.
 right.
 tauto.
 intros.
 discriminate H1.
 intros.
 discriminate H1.
 simpl in |- *.
 intros.
 discriminate H.
Qed.

Lemma access_diam_some:forall (rp:rule_pattern I J) decI decJ n b j
                   (Gamma Gamma':context I J A W),
                    access decI decJ (pdiam j rp) n Gamma=((Some Gamma'), b) ->
                   {Gamma1:context I J A W|Gamma=(TDiamond j Gamma1) /\
                    access decI decJ rp n Gamma1=((Some Gamma'), b)}.
 simpl in |- *.
 intros rp decI decJ n b j Gamma Gamma'; case Gamma.
 intros; discriminate H.
 intros; discriminate H.
 intro j0; case (decJ j j0).
 intros.
 exists c.
 subst; tauto.
 intros.
 discriminate H.
Qed.

Lemma access_diam_TDiam:forall (rp:rule_pattern I J) decI decJ n b j
                   (Gamma Gamma':context I J A W),
                    access decI decJ  rp n (TDiamond j Gamma)=((Some Gamma'), b) ->
                   {rp1:rule_pattern I J|rp=(pdiam j rp1) /\
                    access decI decJ rp1 n Gamma=((Some Gamma'), b)}+
                   {j:nat|rp=pvar j}.
 intros  rp; case rp.
 intros; right; econstructor; eauto.
 simpl in |- *.
 intros.
 discriminate H.
 intros; left.
 generalize H; simpl in |- *.
 case (decJ j j0).
 intros.
 subst.
 exists r.
 tauto.
 intros.
 discriminate H0.
Qed.

Lemma access_diam_none:forall  (rp:rule_pattern I J) decI decJ n  j
                      (Gamma :context I J A W),
                    access decI decJ (pdiam j rp) n Gamma=(None, true) ->
                   {Gamma1:context I J A W|Gamma=(TDiamond j Gamma1) /\
                    access decI decJ rp n Gamma1=(None,true)}.
 simpl.
 intros rp decI decJ n j Gamma; case Gamma.
 intros; discriminate H.
 intros; discriminate H.
 intro j0; case (decJ j j0).
 intros.
 exists c.
 subst; tauto.
 intros.
 discriminate H.
Qed.

Lemma access_some_true: forall (rp1:rule_pattern I J) decI decJ n b
                   (Gamma Gamma':context I J A W),
                   access decI decJ rp1 n Gamma=(Some Gamma', b)->
                   b=true.
 intros rp1; elim rp1.
 intros n decI decJ n0 b Gamma Gamma'.
 simpl in |- *.
 case (eq_nat_dec n n0).
 intros.
 injection H; auto.
 intros.
 discriminate H.
 intros.
 elim (access_com_some _ _ _ _ _ _ _ H1).
 intros Gamma1 H2; elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intro H3; elim H3; clear H3; intros H3 H4.
 eauto.
 eauto.
 intros.
 elim (access_diam_some _ _ _ _ _ _ H0).
 intros Gamma1 H1.
 elim H1; clear H1; intros.
 eauto.
Qed.

Lemma access_dec:forall (rp1:rule_pattern I J) decI decJ n
                   (Gamma :context I J A W),
                 (exists Gamma', access decI decJ rp1 n Gamma=(Some Gamma', true)) \/
                 (exists b:bool,  access decI decJ rp1 n Gamma=(None ,
                   b)).
Proof.
 intros.
 cut
 ((exists Gamma' : context I J A W,
     (exists b : bool, access decI decJ rp1 n Gamma = (Some Gamma', b))) \/
  (exists b : bool, access decI decJ rp1 n Gamma = (None, b))).
 intro H0; elim H0; intros.
 elim H; clear H; intros Gamma' H; elim H; clear H; intros.
 rewrite (access_some_true _ _ _ _ _ H) in H.
 left; econstructor; eauto.
 tauto.
 case (access decI decJ rp1 n Gamma).
 intros o b; case o.
 intro; left; econstructor; econstructor; eauto.
 right; econstructor; eauto.
Qed.

Lemma access_leaf:forall decI decJ (rp1:rule_pattern I J) (Gamma
                   Gamma':context I J A W) n,
                   access decI decJ rp1 n Gamma=(Some Gamma', true)->
                   isLeaf n rp1.
Proof.
 intros decI decJ rp1; elim rp1; intros.
 simpl in |- *.
 generalize H; simpl in |- *.
 case (eq_nat_dec n n0).
 auto.
 intros.
 discriminate H0.
 simpl in |- *.
 elim (access_com_some _ _ _ _ _ _ _ H1).
 intros Gamma1 H2.
 elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intros.
 elim H3; clear H3; intros.
 left; eauto.
 right; elim H3; eauto.
 simpl in |- *.
 elim (access_diam_some _ _ _ _ _ _ H0).
 intros Gamma0 H1.
 elim H1; eauto.
Qed.

Lemma access_is_sub_cont:forall decI decJ (rp:rule_pattern I J)
                        (Gamma Gamma':context I J A W) n,
                        access decI decJ rp n Gamma=(Some Gamma',true)->
                        is_sub_cont Gamma' Gamma.
intros decI decJ rp; elim rp; intros.
generalize H;clear H;simpl.
case (eq_nat_dec n n0).
 intros.
injection H.
intro;subst;constructor.
discriminate 2.
elim (access_com_some _ _ _ _ _ _ _ H1).
intros Gamma1 H2.
 elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intros;elim H3; clear H3; intros;subst.
constructor.
eauto.
subst;constructor 3.
eauto.
elim (access_diam_some _ _ _ _ _ _ H0).
 intros T H1;decompose [and] H1.
subst;constructor;eauto.
Qed.

Lemma access_leaf_false:forall decI decJ (rp:rule_pattern I J)
                        (Gamma:context I J A W) n,
                        isLeaf n rp ->
                        access decI decJ rp n Gamma=(None,true)->
                        False.
 intros decI decJ rp; elim rp; intros.
 generalize H0; clear H0; simpl in |- *.
 case (eq_nat_dec n n0).
 intros.
 discriminate H0.
 simpl in H.
 intros.
 elim n1; auto.
 simpl in H1.
 elim (access_com_none _ _ _ _ _ _ _ H2).
 intros Gamma1 H3; elim H3; clear H3; intros Gamma2 H3.
 elim H3; clear H3; intros.
 elim H1; elim H4; intros; eauto.
 simpl in H0.
 elim (access_diam_none _ _ _ _ _ _ H1).
 intros Gamma0 H2; elim H2; clear H2; intros.
 eauto.
Qed.

Lemma access_pathL:forall  decI decJ n (rp1 rp2:rule_pattern I J)
 (i:I)(Gamma0 Gamma1 Gamma2 Gamma' Gamma:context I J A W),
 access decI decJ rp1 n Gamma=(Some Gamma',true)->
 access decI decJ (pcomma i rp1 rp2) n (Comma i Gamma1 Gamma2)=(Some
 Gamma0 , true)->
 access decI decJ rp1 n Gamma1=(Some Gamma0 , true).

 intros.
 elim (access_com_some _ _ _ _ _ _ _ H0).
 intros Gamma3 H1; elim H1; clear H1; intros Gamma4 H1.
 elim H1; clear H1; intros H1 H2; elim H2; clear H2; intros.
 injection H1; intros; subst.
 tauto.
 injection H1; intros; subst.
 elim H2; clear H2; intros.
 cut (isLeaf n rp1).
 intro.
 elim (access_leaf_false _ _ _ _ _ H4 H3).
 eapply access_leaf; eauto.
Qed.

Lemma access_pathR:forall decI decJ n (rp1 rp2:rule_pattern I J)
 (i:I)(Gamma0 Gamma1 Gamma2 Gamma' Gamma:context I J A W),
 access decI decJ rp2 n Gamma=(Some Gamma',true)->
 access decI decJ (pcomma i rp1 rp2) n (Comma i Gamma1 Gamma2)=
           (Some Gamma0 , true)->
 access decI decJ rp2 n Gamma2=(Some Gamma0 , true).

 intros.
 elim (access_com_some _ _ _ _ _ _ _ H0).
 intros Gamma3 H1; elim H1; clear H1; intros Gamma4 H1.
 elim H1; clear H1; intros H1 H2; elim H2; clear H2; intros.
 cut (isLeaf n rp2).
 intro.
 elim H2; clear H2; intros.
 elim (access_leaf_false _ _ _ _ _ H3 H4).
 eapply access_leaf; eauto.
 injection H1; intros; subst; tauto.
Qed.

Lemma apply_rule_pvar:forall (rp1:rule_pattern I J) decI decJ n (t
                           t':context I J A W),
                           apply_rule (rp1, (pvar n))  decI decJ t=Some t' ->
                          {b:bool |access decI decJ rp1 n t=((Some t'), b)}.
 simpl in |- *.
 intros rp1 decI decJ n t t'.
 case (access decI decJ rp1 n t).
 intros o b; case o.
 intros.
 injection H; intros; subst; econstructor; eauto.
 intro H; discriminate H.
Qed.

Lemma apply_rule_com:forall (rp1 rp2 rp3: rule_pattern I J) decI decJ i
                           (t t':context I J A W),
               apply_rule (rp1, (pcomma i rp2 rp3)) decI decJ t=Some t' ->
               {t1:context I J A W&{t2:context I J A W | t'=(Comma i t1 t2) /\
                             apply_rule (rp1, rp2) decI decJ t =Some t1 /\
                             apply_rule (rp1, rp3) decI decJ t=Some t2}}.
 simpl.
 intros.
 generalize H; clear H.
 case (compile decI decJ rp1 rp3 t).
 case (compile decI decJ rp1 rp2 t).
 intros.
 injection H; econstructor;econstructor.
 split.
 eauto.
 auto.
 intros.
 discriminate H.
 case (compile decI decJ rp1 rp2 t);intros.
 discriminate H.
 discriminate H.
Qed.

Lemma apply_rule_diam: forall (rp1 rp2: rule_pattern I J)decI decJ i
                       (t t':context I J A W),
                      apply_rule (rp1,(pdiam i rp2)) decI decJ t =Some t' ->
                      {t1:context I J A W |t'=TDiamond i t1 /\ apply_rule (rp1, rp2) decI decJ t=Some t1}.
 intros.
 generalize H; clear H; simpl.
 case (compile  decI decJ rp1 rp2 t).
 intros.
 injection H; econstructor.
 split;eauto.
 intro H; discriminate H.
Qed.

Lemma access_same_shape_true:forall decI decJ rp1 opt
                        (n:nat)(Gamma:context I J A W),
                        access decI decJ rp1  n Gamma =(opt, true)->
                        same_shape rp1 Gamma.
 intros decI decJ rp1; elim rp1.
 intros; constructor.
 intros.
 generalize H1; case opt.
 intros.
 elim (access_com_some _ _ _ _ _ _ _ H2).
 clear H2.
 intros Gamma1 H2; elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intro H3; elim H3; clear H3; intros H3 H4.
 rewrite H2.
 constructor; eauto.
 rewrite H2; constructor; eauto.
 intro.
 elim (access_com_none _ _ _ _ _ _ _ H2); clear H2.
 intros Gamma1 H2; elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 rewrite H2.
 elim H3; intros; constructor; eauto.
 intros.
 generalize H0; clear H0; case opt; intros.
 elim (access_diam_some _ _ _ _ _ _ H0).
 intros Gamma1 H1.
 elim H1; clear H1; intros.
 subst.
 constructor; eauto.
 elim (access_diam_none _ _ _ _ _ _ H0).
 intros Gamma1 H1; elim H1; intros.
 subst; constructor; eapply H; eauto.
Qed.

Lemma access_same_shape:forall decI decJ b (n:nat)(Gamma
                          Gamma':context I J A W)rp1,
                          access decI decJ rp1 n Gamma=((Some Gamma'), b) ->
                          same_shape rp1 Gamma.
Proof.
intros.
rewrite (access_some_true _ _ _ _ _ H) in H.
eapply access_same_shape_true; eauto.
Qed.

Lemma apply_rule_same_shape:forall decI decJ  (r1 r2: rule_pattern I J )
                           (t t':context I J A W),
                             (apply_rule (r1 , r2) decI decJ  t)=Some t'->
                             same_shape r1 t.

 intros.
 generalize t' H; clear t' H.
 elim r2.
 intros.
 elim apply_rule_pvar with (1 := H).
 intros.
 eapply access_same_shape; eauto.
 intros.
 elim apply_rule_com with (1:= H1).
 intros.
 elim p; clear p; intros.
 elim p; clear p; intros.
 elim H3; clear H3; intros.
 eauto.
 intros.
 elim apply_rule_diam with (1 := H0).
 intros.
 elim p; intros.
 eauto.
Qed.

Lemma apply_rule_same_shape2:forall decI decJ  (r1 r2: rule_pattern I J )
                           (t t':context I J A W),
                             (apply_rule (r1 , r2) decI decJ  t)=Some t'->
                             same_shape r2 t'.
Proof.
 intros decI decJ r1 r2; elim r2; intros.
 constructor.
 elim (apply_rule_com _ _ _ _ _ _ _ H1).
 intro t1.
 intro H2; elim H2; clear H2; intros t2 H2.
 elim H2; clear H2; intros.
 subst.
 elim H3; intros; constructor; eauto.
 elim (apply_rule_diam _ _ _ _ _ _ H0).
 intros t1 H1; elim H1; clear H1; intros.
 subst.
 constructor; eauto.
Qed.

(* access, apply_rule and par_replace *)
Definition access_par_replace:forall (r:resource W)(Gamma1 Gamma1'
Delta:context I J A W)decI decJ A1 n,
 par_replace (res r A1) Delta Gamma1 Gamma1'->
forall (rp:rule_pattern I J)(Gamma2 Gamma2':context I J A W),
 access decI decJ rp n Gamma1=(Some Gamma2, true)->
 access decI decJ rp n Gamma1'=(Some Gamma2', true)->
 par_replace (res r A1) Delta Gamma2 Gamma2'.

 induction 1.
 intros.
 rewrite H in H0.
 injection H0.
 intro; subst; constructor.
 intros.
 elim (access_res _ _ _ _ _ _ H).
 intros i H1.
 subst.
 generalize H H0; clear H H0; simpl in |- *.
 case (eq_nat_dec i n).
 intros.
 injection H; injection H0.
 intros; subst.
 constructor.
 intros.
 discriminate H.
 intros.
 elim (access_Com_some _ _ _ _ _ _ _ H1).
 intro H3.
 elim H3; clear H3; intros rp1 H3.
 elim H3; clear H3; intros rp2 H3.
 elim H3; clear H3; intros H3 H4.
 elim (access_Com_some _ _ _ _ _ _ _ H2).
 intro H5.
 elim H5; clear H5; intros r1 H5; elim H5; clear H5; intros r2 H5.
 elim H5; clear H5; intros H5 H6.
 rewrite H6 in H4; injection H4; intros; subst.
 elim H3.
 intro H6.
 elim H6; clear H6; intros.
 eapply IHpar_replace1.
 eauto.
 eapply access_pathL; eauto.
 intro H6; elim H6; clear H6; intros.
 eapply IHpar_replace2.
 eauto.
 eapply access_pathR; eauto.
 intro H5; elim H5; clear H5; intros; subst.
 discriminate p.
 intro H3; elim H3; clear H3; intros j H3.
 generalize H1 H2; clear H1 H2; subst.
 simpl in |- *.
 case (eq_nat_dec j n).
 intros.
 injection H1; injection H2; intros; subst.
 constructor.
 auto.
 auto.
 intros.
 discriminate H1.
 intros.
 elim (access_diam_TDiam _ _ _ _ _ _ H0).
 intro H2.
 elim H2; clear H2; intros rp1 H2.
 elim H2; clear H2; intros.
 elim (access_diam_TDiam _ _ _ _ _ _ H1).
 intro H4; elim H4; clear H4; intros rp2 H4; elim H4; clear H4; intros.
 rewrite H2 in H4; injection H4; intros; subst.
 eauto.
 intro H5; elim H5; intros k H6; rewrite H6 in H2; discriminate H2.
 intro H2; elim H2; clear H2; intros k H2; subst.
 generalize H0 H1; simpl in |- *.
 case (eq_nat_dec k n).
 intros.
 injection H2; injection H3; intros; subst.
 constructor; auto.
 intros.
 discriminate H2.
Defined.

Definition apply_rule_par_replace:forall ru (r:resource W)(Gamma1 Gamma1'
Gamma2 Gamma2' Delta:context I J A W)decI decJ A1 ,
 par_replace (res r A1) Delta Gamma1 Gamma1'->
 apply_rule ru decI decJ  Gamma1=Some Gamma2->
 apply_rule ru decI decJ Gamma1'=Some Gamma2'->
 par_replace (res r A1) Delta Gamma2 Gamma2'.

 intro ru; case ru; intros r1 r2; elim r2; intros.
 elim (apply_rule_pvar _ _ _ _ _ H0).
 intros b H2.
 clear H0.
 elim (apply_rule_pvar _ _ _ _ _ H1); clear H1.
 intros b1 H1.
 rewrite (access_some_true _ _ _ _ _ H2) in H2.
 rewrite (access_some_true _ _ _ _ _ H1) in H1.
 eapply access_par_replace; eauto.
 elim (apply_rule_com _ _ _ _ _ _ _ H2).
 clear H2; intros Gamma11 H2.
 elim H2; clear H2; intros Gamma12 H2.
 elim H2; clear H2; intros H2 H4.
 elim H4; clear H4; intros.
 subst.
 elim (apply_rule_com _ _ _ _ _ _ _ H3).
 clear H3; intros Gamma21 H3.
 elim H3; clear H3; intros Gamma22 H3.
 elim H3; clear H3; intros H3 H6.
 elim H6; clear H6; intros.
 subst.
 constructor.
 eapply H;eauto.
 eapply H0 ;eauto.
 elim (apply_rule_diam _ _ _ _ _ _ H1); clear H1.
 intros Gamma11 H3.
 elim H3; clear H3; intros.
 subst.
 subst.
 elim (apply_rule_diam _ _ _ _ _ _ H2); clear H2.
 intros Gamma11' H4; elim H4; clear H4; intros.
 subst; constructor; eauto.
Defined.

Lemma acces_leaf_shape: forall decI decJ (n:nat)(rp:rule_pattern I J)
                     (Gamma:context I J A W),
                      ~isLeaf n rp ->
                      same_shape rp Gamma->
                      access decI decJ rp n Gamma =(None, true).
 induction 2.
 simpl in H.
 simpl in |- *.
 elim (eq_nat_dec n0 n).
 intro.
 absurd (n = n0); auto.
 auto.
 simpl in H.
 elim (isLeaf_dec n r1); elim (isLeaf_dec n r2); intros.
 elim H; tauto.
 elim H; tauto.
 elim H; tauto.
 simpl in |- *.
 case (decI i i).
 generalize IHsame_shape1; generalize IHsame_shape2.
 case (access decI decJ r1 n Gamma1).
 intros o b1; case o.
 case (access decI decJ r2 n Gamma2).
 intros.
 cut ((Some c, b1) = (None, true)).
 intro D; discriminate D.
 auto.
 case b1.
 intros.
 auto.
 intros.
 tauto.
 tauto.
 simpl in H.
 simpl in |- *.
 case (decJ j j);tauto.
Qed.

Lemma acces_isLeaf: forall decI decJ (n:nat)(rp:rule_pattern I J)
                     (Gamma:context I J A W), ~isLeaf n rp ->
                     {b:bool|access decI decJ rp n Gamma=(None, b)}.
 intros  decI decJ n rp.
 elim rp; intros.
 simpl in |- *.
 elim (eq_nat_dec n0 n).
 simpl in H.
 intro.
 absurd (n = n0); auto.
 auto.
 intro; econstructor; eauto.
 simpl in H1.
 simpl in |- *.
 case Gamma.
 intros; econstructor; eauto.
 elim (isLeaf_dec n r).
 intros.
 elim H1; tauto.
 intros; elim (isLeaf_dec n r0).
 intro; elim H1; tauto.
 intros.
 simpl in |- *.
 case (decI i0 i).
 intros.
 elim (H c b).
 intros.
 rewrite p.
 elim x.
 eauto.
 econstructor; eauto.
 intro; econstructor; eauto.
 intros; econstructor; eauto.
 simpl in H0.
 case Gamma; simpl in |- *.
 intros; econstructor; eauto.
 intros; econstructor; eauto.
 intros.
 elim (decJ j j0).
 intro; auto.
 intro; econstructor; eauto.
Qed.

Lemma acces_same_shape:forall decI decJ (rp1:rule_pattern I J)
                      (Gamma:context I J A W) n,
                       allDistinctLeaves rp1 -> isLeaf n rp1 ->
                       same_shape rp1 Gamma ->
                       {Gamma' : context I J A W | access decI decJ rp1 n Gamma = ((Some Gamma'),true)}.

 intros decI decJ rp1; elim rp1; intros.
 simpl in H0.
 subst.
 econstructor.
 simpl in |- *.
 case (eq_nat_dec n n).
 eauto.
 tauto.
 elim (sameShapeCom H3).
 intros.
 elim p; intros.
 elim p0; clear p0; intros.
 subst.
 clear p.
 simpl in H1.
 simpl in |- *.
 elim H1; clear H1; intros.
 elim H4; clear H4; intros.
 elim (isLeaf_dec_com H6 H2).
 intros.
 elim a; clear a; intros.
 elim H5; clear H5; intros.
 elim (H _ _ H1 H7 H5).
 intros.
 rewrite p.
 elim (decI i i).
 intro.
 exists x1.
 rewrite (acces_leaf_shape decI decJ _ H8 H9).
 auto.
 tauto.
 intros.
 elim b; clear b; intros.
 elim H5; clear H5; intros.
 elim (H0 _ _ H4 H7 H9).
 intros.
 rewrite p.
 exists x1.
 case (decI i i).
 rewrite (acces_leaf_shape decI decJ _ H8 H5).
 auto.
 tauto.
 simpl in H1.
 simpl in H0.
 elim (sameShapeDiam H2).
 intros.
 elim p; clear p; intros; subst.
 simpl in |- *.
 elim (H _ _ H0 H1 H4).
 intros.
 exists x0.
 case (decJ j j);tauto.
Qed.

Lemma access_sub_cont:forall (decI:eqdec I)(decJ :eqdec
J)(rp:rule_pattern I J)(Gamma:context I J A W) l ,
               allDistinctLeaves rp->
               hasSubContexts rp Gamma l->
               forall n (Delta :context I J A W)i,
               (nth_error (flatten_pattern rp) i)=Some n ->
                access decI decJ rp n Gamma=(Some Delta,true)->
                nth_error l i=Some Delta.

Proof.
 induction 2.
 simpl in |- *.
 intro n ; case (eq_nat_dec i n).
 intros H0 Delta0 i0;case i0.
 simpl in |- *.
 injection 2; intros; subst; auto.
 intro n0; case n0; discriminate 1.
 discriminate 3.
 intros.
 simpl in H0.
 elim (nth_error_app _ _ _ H0); intro.
 apply nth_error_fst_app.
 simpl in H; decompose [and] H; clear H.
 elim
 (acces_same_shape decI decJ n H3 (nth_flatten_leaf _ _ H2)
        (same_shape_SubCont H0_)).
 intros.
 eapply IHhasSubContexts1; eauto.
 eapply access_pathL; eauto.
 decompose [and] H2; clear H2.
 replace i0 with (i0 - length l1 + length l1).
 apply nth_error_scd_app.
 simpl in H; decompose [and] H; clear H.
 elim
  (acces_same_shape decI decJ n H6 (nth_flatten_leaf _ _ H4)
         (same_shape_SubCont H0_0)).
 intros.
 eapply IHhasSubContexts2; eauto.
 rewrite (subCont_length H0_); eauto.
 eapply access_pathR; eauto.
 rewrite (subCont_length H0_).
 omega.
 intros.
 simpl in H1.
 elim (access_diam_some _ _ _ _ _ _ H2).
 intros Gamma H3; decompose [and] H3; clear H3.
 injection H4; intros; subst; eauto.
Qed.

Lemma access_subCont:forall (decI:eqdec I)(decJ :eqdec
J)(rp:rule_pattern I J)(Gamma:context I J A W) l i,
               allDistinctLeaves rp->
               hasSubContexts rp Gamma l->
               i<length l->
               (exists n:nat,(exists Delta:context I J A W,
               (nth_error (flatten_pattern rp) i)=Some n /\
                access decI decJ rp n Gamma=(Some Delta,true)/\
                nth_error l i=Some Delta)).

Proof.
 intros.
 rewrite (subCont_length H0) in H1.
 elim (nth_error_length _ H1).
 intros n H2.
 exists n.
 elim
 (acces_same_shape decI decJ _ H (nth_flatten_leaf _ _ H2)
    (same_shape_SubCont H0)).
 intros Delta H3.
 exists Delta.
 split.
 auto.
 split.
 auto.
 eapply access_sub_cont; eauto.
Qed.

Lemma access_eq_apply:forall decI decJ (rp1 rp2:rule_pattern I J)(T1
                      T2 T:context I J A W) (i:nat),
                      apply_rule (rp1 , rp2) decI decJ T1 =Some T2->
                      access decI decJ rp2 i T2=(Some T,true)->
                      access decI decJ rp1 i T1=(Some T,true).
Proof.
 intros decI decJ rp1 rp2; elim rp2.
 simpl in |- *.
 intros n T1 T2 T i.
 case (eq_nat_dec n i).
 intro; subst.
 elim (access_dec rp1 decI decJ i T1).
 intro H; elim H.
 clear H; intros T' H.
 rewrite H.
 injection 1; intros; subst; auto.
 intro H; elim H; clear H; intros b H; rewrite H.
 discriminate 1.
 discriminate 3.
 intros.
 elim (apply_rule_com _ _ _ _ _ _ _ H1).
 intros T' H3.
 elim H3; clear H3; intros T1' H3.
 elim H3; clear H3; intros H3 H4; elim H4; clear H4; intros H4 H5.
 subst.
 elim (access_com_some _ _ _ _ _ _ _ H2).
 intros Gamma1 H3.
 elim H3; clear H3; intros Gamma2 H3.
 elim H3; clear H3; intro H3.
 intro H6; elim H6; clear H6; intro H6; elim H6; clear H6; intros H6 H7.
 injection H3; intros; subst.
 eauto.
 injection H3; intros; subst; eauto.
 intros.
 elim (apply_rule_diam _ _ _ _ _ _ H0).
 intros T' H2; elim H2; clear H2; intros.
 subst.
 elim (access_diam_some _ _ _ _ _ _ H1).
 intros Gamma H2; elim H2; clear H2; intros.
 injection H2; intros; subst; eauto.
Qed.

Lemma permut_sub_cont:forall decI decJ (rp1 rp2:rule_pattern I J)(T1
                      T2 :context I J A W)l1 l2,
                         allDistinctLeaves rp1->
                         allDistinctLeaves rp2->
                        permut (flatten_pattern rp1) (flatten_pattern rp2)->
                        apply_rule  (rp1 , rp2) decI decJ T1 =Some T2->
                        hasSubContexts rp1 T1 l1->
                        hasSubContexts rp2 T2 l2->
                        permut l1 l2.
Proof.

 intros.
 pose (f := fun n : nat => let (p1, _) := access decI decJ rp1 n T1 in p1).
 cut (permut (map f (flatten_pattern rp1)) (map f (flatten_pattern rp2))).
 intro.
 eapply permut_extract.
 eexact H5.
 apply extract_forall.
 rewrite (subCont_length H3).
 rewrite map_length; auto.
 intros.
 assert (i < length l1).
 eapply nth_error_some_length.
 eauto.
 elim (access_subCont decI decJ H H3 H7).
 intros n H8; decompose [ex] H8.
 clear H8.
 decompose [and] H9; clear H9.
 rewrite (nth_map f _ _ H8).
 unfold f in |- *; simpl in |- *.
 rewrite H11.
 rewrite H12 in H6; injection H6.
 intro; subst; auto.
 apply extract_forall.
 rewrite (subCont_length H4).
 rewrite map_length; auto.
 intros.
 assert (i < length l2).
 eapply nth_error_some_length; eauto.
 elim (access_subCont decI decJ H0 H4 H7); intros.
 decompose [ex and] H8; clear H8.
 rewrite (nth_map f _ _ H10).
 unfold f in |- *; simpl in |- *.
 rewrite (access_eq_apply _ _ _ _ _ _ H2 H9).
 rewrite H12 in H6; injection H6; intro; subst; auto.
 apply map_permut; auto.
Qed.

End props.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ProofTheory.BasicDeduction.
Require Import Logic.GeneralLogic.ProofTheory.BasicLogicEquiv.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.
Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.ProofTheory.ProofRules.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import CoqPropInLogicNotation.
Import SeparationLogicNotation.

Class SepconAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  sepcon_comm_impp: forall x y, |-- x * y --> y * x;
  sepcon_assoc1: forall x y z, |-- x * (y * z) --> (x * y) * z;
  sepcon_mono: forall x1 x2 y1 y2, |-- x1 --> x2 -> |-- y1 --> y2 -> |-- (x1 * y1) --> (x2 * y2);
}.

Class SepconOrAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {orpL: OrLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  orp_sepcon_impp: forall (x y z: expr),
    |-- (x || y) * z --> x * z || y * z
}.

Class SepconCoqPropAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {iffpL: IffLanguage L}
        {coq_prop_L: CoqPropLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  prop_andp_sepcon1: forall P Q R,
    |-- (!! P && Q) * R <--> !! P && (Q * R)
}.

Class SepconFalseAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {falsepL: FalseLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  falsep_sepcon_impp: forall (x: expr),
    |-- FF * x --> FF
}.

Class EmpAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
    sepcon_emp1: forall x, |-- x * emp --> x;
    sepcon_emp2: forall x, |-- x --> x * emp
}.

Class WandAxiomatization
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        (Gamma: Provable L) := {
  wand_sepcon_adjoint: forall x y z, |-- x * y --> z <-> |-- x --> (y -* z)
}.

Class ExtSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {trueL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  sepcon_ext: forall x, |-- x --> x * TT
}.

Class NonsplitEmpSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  emp_sepcon_truep_elim: forall x, |-- (x * TT) && emp --> x
}.

Class DupEmpSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  emp_dup: forall x, |-- x && emp --> x * x
}.

(* Only for documentation *)
Class MallocFreeSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (Gamma: Provable L) := {
  MallocFreeSeparationLogic_NonsplitEmpSeparationLogic :>
    NonsplitEmpSeparationLogic L Gamma;
  MallocFreeSeparationLogic_DupEmpSeparationLogic :>
    DupEmpSeparationLogic L Gamma
}.

Class GarbageCollectSeparationLogic
        (L: Language)
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        (Gamma: Provable L) := {
  sepcon_elim1: forall x y, |-- x * y --> x
}.

Class SepconDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_sepcon_comm: forall x y, x * y |-- y * x;
  derivable1_sepcon_assoc1: forall x y z, x * (y * z) |-- (x * y) * z;
  derivable1_sepcon_mono: forall x1 x2 y1 y2, x1 |-- x2 -> y1 |-- y2
               -> (x1 * y1) |-- (x2 * y2);
}.

Class SepconOrDeduction
        (L: Language)
        {orpL: OrLanguage L}
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  orp_sepcon_left: forall x y z,
     (x || y) * z |-- x * z || y * z
}.

Class SepconFalseDeduction
        (L: Language)
        {falsepL: FalseLanguage L}
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  falsep_sepcon_left: forall x,
     FF * x |-- FF
}.

Class EmpDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (GammaD1: Derivable1 L) := {
    sepcon_emp_left: forall x,  x * emp |-- x;
    sepcon_emp_right: forall x, x |-- x * emp
}.

Class WandDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_wand_sepcon_adjoint: forall x y z, x * y  |-- z <-> x |-- (y -* z)
}.

Class ExtSeparationLogicDeduction
        (L: Language)
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_sepcon_ext: forall x, x |-- x * TT
}.

Class NonsplitEmpSeparationLogicDeduction
        (L: Language)
        {andpL: AndLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_emp_sepcon_truep_elim: forall x, (x * TT) && emp |-- x
}.

Class DupEmpSeparationLogicDeduction
        (L: Language)
        {andpL: AndLanguage L}
        {sepconL: SepconLanguage L}
        {empL: EmpLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_emp_dup: forall x, x && emp |-- x * x
}.

Class GarbageCollectSeparationLogicDeduction
        (L: Language)
        {sepconL: SepconLanguage L}
        (GammaD1: Derivable1 L) := {
  derivable1_sepcon_elim1: forall x y, x * y |-- x
}.

Section SepconRules.

Context {L: Language}
        {sepconL: SepconLanguage L}
        {GammaD1: Derivable1 L}
        {bD: BasicDeduction L GammaD1}
        {sepconD: SepconDeduction L GammaD1}.

Lemma derivable1_sepcon_Comm: D1.Commutativity L GammaD1 sepcon.
Proof.
  constructor.
  intros.
  apply derivable1_sepcon_comm.
Qed.

Lemma derivable1_sepcon_Mono: D1.Monotonicity L GammaD1 sepcon.
Proof.
  constructor.
  intros.
  apply derivable1_sepcon_mono; auto.
Qed.

Lemma derivable1_sepcon_Assoc: D1.Associativity L GammaD1 sepcon.
Proof.
  apply @D1.Build_Associativity1; auto.
  + apply derivable1_sepcon_Comm.
  + apply derivable1_sepcon_Mono.
  + intros.
    apply derivable1_sepcon_assoc1.
Qed.

Lemma derivable1_sepcon_assoc2: forall x y z, (x * y) * z |-- x * (y * z).
Proof.
  intros.
  apply (@D1.prodp_assoc2 _ _ _ derivable1_sepcon_Assoc).
Qed.

Lemma orp_sepcon_right
      {orpL: OrLanguage L}
      {orpD: OrDeduction L GammaD1}:
  forall (x y z: expr), x * z || y * z |-- (x || y) * z.
Proof.
  intros.
  apply derivable1_orp_elim; apply derivable1_sepcon_mono.
  - apply derivable1_orp_intros1.
  - reflexivity.
  - apply derivable1_orp_intros2.
  - reflexivity.
Qed.

Lemma falsep_sepcon_right
      {falsepL: FalseLanguage L}
      {falsepD: FalseDeduction L GammaD1}:
  forall (x: expr), FF |-- FF * x.
Proof.
  intros.
  apply derivable1_falsep_elim.
Qed.

Section emp.

Context {empL: EmpLanguage L}
        {empD: EmpDeduction L GammaD1}.

Lemma derivable1_sepcon_LU: D1.LeftUnit L GammaD1 emp sepcon.
Proof.
  constructor; intros.
  + rewrite derivable1_sepcon_comm.
    apply sepcon_emp_left.
  + rewrite <- derivable1_sepcon_comm.
    apply sepcon_emp_right.
Qed.

Lemma derivable1_sepcon_RU: D1.RightUnit L GammaD1 emp sepcon.
Proof.
  constructor; intros.
  intros.
  + apply sepcon_emp_left.
  + apply sepcon_emp_right.
Qed.

End emp.

Context {GammaE: LogicEquiv L}
        {GammED1: EquivDerivable1 L GammaD1 GammaE}
        {bE: BasicLogicEquiv L GammaE}.

Lemma sepcon_comm_logic_equiv:
  forall (x y: expr), x * y --||-- y * x.
Proof.
  intros.
  apply (@D1.prodp_comm _ _ _ _ _ derivable1_sepcon_Comm).
Qed.

Lemma sepcon_assoc_logic_equiv:
  forall x y z, x * (y * z) --||-- (x * y) * z.
Proof.
  intros.
  apply (@D1.prodp_assoc _ _ _ _ _ derivable1_sepcon_Assoc).
Qed.

Section emp.

Context {empL: EmpLanguage L}
        {empD: EmpDeduction L GammaD1}.

Lemma sepcon_emp_logic_equiv: forall x, x * emp --||-- x.
Proof. apply (@D1.right_unit _ _ _ _ _ _ derivable1_sepcon_RU). Qed.

Lemma emp_sepcon_logic_equiv: forall x, emp * x --||-- x.
Proof. apply (@D1.left_unit _ _ _ _ _ _ derivable1_sepcon_LU). Qed.

End emp.

Context {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {orpD: OrDeduction L GammaD1}
        {falsepD: FalseDeduction L GammaD1}
        {sepcon_orp_D: SepconOrDeduction L GammaD1}
        {sepcon_falsep_D: SepconFalseDeduction L GammaD1}.

Lemma derivable1_sepcon_orp_RDistr: D1.RightDistr L GammaD1 sepcon orp.
Proof.
  constructor; intros.
  + apply orp_sepcon_left.
  + apply orp_sepcon_right.
Qed.

Lemma derivable1_sepcon_orp_LDistr: D1.LeftDistr L GammaD1 sepcon orp.
Proof.
  apply @D1.RightDistr2LeftDistr; auto.
  + apply derivable1_sepcon_Comm.
  + apply derivable1_orp_Mono.
  + apply derivable1_sepcon_orp_RDistr.
Qed.

Lemma sepcon_orp_distr_r: forall (x y z: expr),
  (x || y) * z --||-- x * z || y * z.
Proof.
  intros.
  apply (@D1.prodp_sump_distr_r _ _ _ _ _ _ derivable1_sepcon_orp_RDistr).
Qed.

Lemma sepcon_orp_distr_l: forall (x y z: expr),
  x * (y || z) --||-- x * y || x * z.
Proof.
  intros.
  apply (@D1.prodp_sump_distr_l _ _ _ _ _ _ derivable1_sepcon_orp_LDistr).
Qed.

Lemma falsep_sepcon_logic_equiv: forall (x: expr),
  FF * x --||-- FF.
Proof.
  intros.
  apply logic_equiv_derivable1; split.
  + apply falsep_sepcon_left.
  + apply falsep_sepcon_right.
Qed.

Lemma sepcon_falsep_logic_equiv: forall (x: expr),
  x * FF --||-- FF.
Proof.
  intros.
  rewrite sepcon_comm_logic_equiv.
  apply falsep_sepcon_logic_equiv.
Qed.

End SepconRules.

(*
(** Proof rules for cancel. **)

Lemma cancel_ready: forall x y, |-- x * emp --> y -> |-- x --> y.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- sepcon_emp2 in H.
  auto.
Qed.

Lemma cancel_one_succeed: forall u x y z,
  |-- x * y --> z -> |-- (u * x) * y --> u * z.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite sepcon_assoc2.
  apply sepcon_mono; auto.
  apply provable_impp_refl.
Qed.

Lemma cancel_one_giveup: forall x y z w v,
  |-- x * (y * z) --> w * v-> |-- (y * x) * z --> w * v.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp y x.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite H1.
  apply sepcon_assoc2.
Qed.

Lemma cancel_rev: forall x y z w,  |-- (y * x) * z --> w -> |-- x * (y * z) --> w.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp x y.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite <- H1.
  apply sepcon_assoc1.
Qed.

Lemma cancel_finish: forall x, |-- x * emp --> x.
Proof.
  apply sepcon_emp1.
Qed.

End SepconRules.
*)
Section WandRules.

Context {L: Language}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {GammaD1: Derivable1 L}
        {bD: BasicDeduction L GammaD1}
        {wandD: WandDeduction L GammaD1}.

Lemma derivable1_wand_sepcon_Adj: D1.Adjointness L GammaD1 sepcon wand.
Proof.
  constructor.
  intros.
  apply derivable1_wand_sepcon_adjoint.
Qed.

Lemma derivable1_wand_sepcon_modus_ponens1: forall (x y: expr),
  (x -* y) * x |-- y.
Proof.
  intros.
  apply (@D1.adjoint_modus_ponens _ _ _ _ _ derivable1_wand_sepcon_Adj).
Qed.

Context {sepconD: SepconDeduction L GammaD1}.

Lemma derivable1_wand_sepcon_modus_ponens2: forall (x y: expr),
  x * (x -* y) |-- y.
Proof.
  intros.
  rewrite (derivable1_sepcon_comm x (x -* y)).
  apply derivable1_wand_sepcon_modus_ponens1.
Qed.

Lemma derivable1_wand_mono: forall x1 x2 y1 y2,
  x2 |-- x1 -> y1 |-- y2 -> x1 -* y1 |-- x2 -* y2.
Proof.
  intros.
  apply (@D1.funcp_mono _ _ _ _ _ derivable1_wand_sepcon_Adj derivable1_sepcon_Mono); auto.
Qed.

Context {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {GammaE: LogicEquiv L}
        {GammED1: EquivDerivable1 L GammaD1 GammaE}
        {bE: BasicLogicEquiv L GammaE}
        {andpD: AndDeduction L GammaD1}
        {orpD: OrDeduction L GammaD1}
        {sepcon_orp_D: SepconOrDeduction L GammaD1}.

Lemma wand_andp_logic_equiv: forall x y z: expr,
  x -* y && z --||-- (x -* y) && (x -* z).
Proof.
  intros.
  apply (@D1.funcp_andp_distr_r _ _ _ _ _ _ _ derivable1_wand_sepcon_Adj); auto.
Qed.

Lemma orp_wand_logic_equiv: forall x y z: expr,
  (x || y) -* z --||-- (x -* z) && (y -* z).
Proof.
  intros.
  apply (@D1.orp_funcp _ _ _ _ _ _ _ _ _ _ derivable1_wand_sepcon_Adj _ _ derivable1_sepcon_Comm); auto.
Qed.

Lemma derivable1_sepcon_elim2: forall {gcsD: GarbageCollectSeparationLogicDeduction L GammaD1} (x y: expr),
  x * y |-- y.
Proof.
  intros.
  rewrite (derivable1_sepcon_comm x y).
  apply derivable1_sepcon_elim1.
Qed.

Lemma derivable1_emp_sepcon_elim1
      {truepL: TrueLanguage L}
      {empL: EmpLanguage L}
      {truepD: TrueDeduction L GammaD1}
      {empD: EmpDeduction L GammaD1}
      {nssD: NonsplitEmpSeparationLogicDeduction L GammaD1}:
  forall x y, x * y && emp |-- x.
Proof.
  intros.
  rewrite <- (derivable1_emp_sepcon_truep_elim x) at 2.
  apply andp_proper_derivable1; [| reflexivity].
  apply derivable1_sepcon_mono; [reflexivity |].
  apply derivable1_truep_intros.
Qed.

Lemma derivable1_emp_sepcon_elim2
      {truepL: TrueLanguage L}
      {empL: EmpLanguage L}
      {truepD: TrueDeduction L GammaD1}
      {empD: EmpDeduction L GammaD1}
      {nssD: NonsplitEmpSeparationLogicDeduction L GammaD1}:
  forall x y, x * y && emp |-- y.
Proof.
  intros.
  rewrite derivable1_sepcon_comm.
  apply derivable1_emp_sepcon_elim1.
Qed.

End WandRules.

Section Axiomatization2Deduction.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {GammaP: Provable L}
        {GammaD1: Derivable1 L}
        {GammaD1P: Derivable1Provable L GammaP GammaD1}
        {minAX: MinimumAxiomatization L GammaP}
        {sepconAX: SepconAxiomatization L GammaP}.

Lemma Axiomatization2Deduction_sepconD: SepconDeduction L GammaD1.
Proof.
  constructor; intros.
  + apply derivable1_provable.
    apply sepcon_comm_impp.
  + apply derivable1_provable.
    apply sepcon_assoc1.
  + rewrite derivable1_provable in H, H0 |- *.
    apply sepcon_mono; auto.
Qed.

Lemma Axiomatization2Deduction_wandD
      {wandL: WandLanguage L}
      {wandAX: WandAxiomatization L GammaP}:
  WandDeduction L GammaD1.
Proof.
  constructor; intros.
  rewrite !derivable1_provable.
  apply wand_sepcon_adjoint.
Qed.

Lemma Axiomatization2Deduction_empD
      {empL: EmpLanguage L}
      {empAX: EmpAxiomatization L GammaP}:
  EmpDeduction L GammaD1.
Proof.
  constructor; intros.
  + rewrite derivable1_provable.
    apply sepcon_emp1.
  + rewrite derivable1_provable.
    apply sepcon_emp2.
Qed.

End Axiomatization2Deduction.

Section SepconRules.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {sepconAX: SepconAxiomatization L Gamma}.

Lemma sepcon_Comm: P.Commutativity L Gamma sepcon.
Proof.
  constructor.
  intros.
  apply sepcon_comm_impp.
Qed.

Lemma sepcon_Mono: P.Monotonicity L Gamma sepcon.
Proof.
  constructor.
  intros.
  apply sepcon_mono; auto.
Qed.

Lemma sepcon_Assoc: P.Associativity L Gamma sepcon.
Proof.
  apply @P.Build_Associativity1; auto.
  + apply sepcon_Comm.
  + apply sepcon_Mono.
  + intros.
    apply sepcon_assoc1.
Qed.

Lemma sepcon_assoc2: forall x y z, |-- (x * y) * z --> x * (y * z).
Proof.
  intros.
  apply (@P.prodp_assoc2 _ _ _ _ sepcon_Assoc).
Qed.

Context {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {andpAX: AndAxiomatization L Gamma}
        {orpAX: OrAxiomatization L Gamma}
        {falsepAX: FalseAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {iffpAX: IffAxiomatization L Gamma}
        {truepAX: TrueAxiomatization L Gamma}.

Lemma sepcon_comm:
  forall (x y: expr), |-- x * y <--> y * x.
Proof.
  intros.
  apply (@P.prodp_comm _ _ _ _ _ _ _ sepcon_Comm).
Qed.

Lemma sepcon_assoc:
  forall x y z, |-- x * (y * z) <--> (x * y) * z.
Proof.
  intros.
  apply (@P.prodp_assoc _ _ _ _ _ _ _ sepcon_Assoc).
Qed.

Lemma impp_orp_sepcon:
  forall (x y z: expr), |-- x * z || y * z --> (x || y) * z.
Proof.
  intros.
  apply solve_orp_impp; apply sepcon_mono.
  - apply orp_intros1.
  - apply provable_impp_refl.
  - apply orp_intros2.
  - apply provable_impp_refl.
Qed.

Lemma impp_falsep_sepcon:
  forall (x: expr),|-- FF --> FF * x.
Proof.
  intros.
  apply falsep_elim.
Qed.

Context {sepcon_orp_AX: SepconOrAxiomatization L Gamma}
        {sepcon_false_AX: SepconFalseAxiomatization L Gamma}.

Lemma sepcon_orp_RDistr: P.RightDistr L Gamma sepcon orp.
Proof.
  constructor; intros.
  + apply orp_sepcon_impp.
  + apply impp_orp_sepcon.
Qed.

Lemma sepcon_orp_LDistr: P.LeftDistr L Gamma sepcon orp.
Proof.
  apply @P.RightDistr2LeftDistr; auto.
  + apply sepcon_Comm.
  + apply orp_Mono.
  + apply sepcon_orp_RDistr.
Qed.

Lemma sepcon_orp_distr_r_iffp: forall (x y z: expr),
  |-- (x || y) * z <--> x * z || y * z.
Proof.
  intros.
  apply (@P.prodp_sump_distr_r _ _ _ _ _ _ _ _ sepcon_orp_RDistr).
Qed.

Lemma sepcon_orp_distr_l_iffp: forall (x y z: expr),
  |-- x * (y || z) <--> x * y || x * z.
Proof.
  intros.
  apply (@P.prodp_sump_distr_l _ _ _ _ _ _ _ _ sepcon_orp_LDistr).
Qed.

Lemma falsep_sepcon: forall (x: expr),
  |-- FF * x <--> FF.
Proof.
  intros.
  apply solve_iffp_intros.
  + apply falsep_sepcon_impp.
  + apply impp_falsep_sepcon.
Qed.

Lemma sepcon_falsep: forall (x: expr),
  |-- x * FF <--> FF.
Proof.
  intros.
  rewrite sepcon_comm.
  apply falsep_sepcon.
Qed.

Context {empL: EmpLanguage L}
        {empAX: EmpAxiomatization L Gamma}.

Lemma sepcon_emp: forall x, |-- x * emp <--> x.
Proof.
  intros.
  apply solve_iffp_intros.
  + apply sepcon_emp1.
  + apply sepcon_emp2.
Qed.

Lemma sepcon_LU: P.LeftUnit L Gamma emp sepcon.
Proof.
  apply P.Build_LeftUnit; intros.
  + rewrite sepcon_comm_impp.
    apply sepcon_emp1.
  + rewrite <- sepcon_comm_impp.
    apply sepcon_emp2.
Qed.

Lemma sepcon_RU: P.RightUnit L Gamma emp sepcon.
Proof.
  apply P.Build_RightUnit.
  intros.
  + apply sepcon_emp1.
  + apply sepcon_emp2.
Qed.

(** Proof rules for cancel. **)

Lemma cancel_ready: forall x y, |-- x * emp --> y -> |-- x --> y.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- sepcon_emp2 in H.
  auto.
Qed.

Lemma cancel_one_succeed: forall u x y z,
  |-- x * y --> z -> |-- (u * x) * y --> u * z.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite sepcon_assoc2.
  apply sepcon_mono; auto.
  apply provable_impp_refl.
Qed.

Lemma cancel_one_giveup: forall x y z w v,
  |-- x * (y * z) --> w * v-> |-- (y * x) * z --> w * v.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp y x.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite H1.
  apply sepcon_assoc2.
Qed.

Lemma cancel_rev: forall x y z w,  |-- (y * x) * z --> w -> |-- x * (y * z) --> w.
Proof.
  clear - minAX sepconAX empAX.
  intros.
  rewrite <- H.
  pose proof sepcon_comm_impp x y.
  pose proof sepcon_mono _ _ _ _ H0 (provable_impp_refl z).
  rewrite <- H1.
  apply sepcon_assoc1.
Qed.

Lemma cancel_finish: forall x, |-- x * emp --> x.
Proof.
  apply sepcon_emp1.
Qed.

End SepconRules.

Section WandRules.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {wandAX: WandAxiomatization L Gamma}.

Lemma wand_sepcon_Adj: P.Adjointness L Gamma sepcon wand.
Proof.
  constructor.
  intros.
  apply wand_sepcon_adjoint.
Qed.

Lemma provable_wand_sepcon_modus_ponens1: forall (x y: expr),
  |-- (x -* y) * x --> y.
Proof.
  intros.
  apply (@P.adjoint_modus_ponens _ _ _ _ _ _ wand_sepcon_Adj).
Qed.

Context {sepconAX: SepconAxiomatization L Gamma}.

Lemma provable_wand_sepcon_modus_ponens2: forall (x y: expr),
  |-- x * (x -* y) --> y.
Proof.
  intros.
  rewrite (sepcon_comm_impp x (x -* y)).
  apply provable_wand_sepcon_modus_ponens1.
Qed.

Lemma wand_mono: forall x1 x2 y1 y2,
  |-- x2 --> x1 -> |-- y1 --> y2 -> |-- (x1 -* y1) --> (x2 -* y2).
Proof.
  intros.
  apply (@P.funcp_mono _ _ _ _ _ _ wand_sepcon_Adj sepcon_Mono); auto.
Qed.

Context {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {andpAX: AndAxiomatization L Gamma}
        {orpAX: OrAxiomatization L Gamma}
        {falsepAX: FalseAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {iffpAX: IffAxiomatization L Gamma}
        {truepAX: TrueAxiomatization L Gamma}
        {sepcon_orp_AX: SepconOrAxiomatization L Gamma}
        {sepcon_false_AX: SepconFalseAxiomatization L Gamma}.

Lemma wand_andp: forall x y z: expr,
  |-- x -* y && z <--> (x -* y) && (x -* z).
Proof.
  intros.
  apply (@P.funcp_andp_distr_r _ _ _ _ _ _ wand_sepcon_Adj); auto.
Qed.

Lemma orp_wand: forall x y z: expr,
  |-- (x || y) -* z <--> (x -* z) && (y -* z).
Proof.
  intros.
  apply (@P.orp_funcp _ _ _ _ _ _ _ _ wand_sepcon_Adj _ _ _ _ sepcon_Comm); auto.
Qed.

Lemma sepcon_elim2: forall {gcsGamma: GarbageCollectSeparationLogic L Gamma} (x y: expr),
  |-- x * y --> y.
Proof.
  intros.
  rewrite (sepcon_comm_impp x y).
  apply sepcon_elim1.
Qed.

Lemma emp_sepcon_elim1: forall {empL: EmpLanguage L} {empAX: EmpAxiomatization L Gamma} {nssGamma: NonsplitEmpSeparationLogic L Gamma} x y,
  |-- x * y && emp --> x.
Proof.
  intros.
  rewrite <- (emp_sepcon_truep_elim x) at 2.
  apply andp_proper_impp; [| apply provable_impp_refl].
  apply sepcon_mono; [apply provable_impp_refl |].
  apply solve_impp_elim_left, provable_truep.
Qed.

Lemma emp_sepcon_elim2: forall {empL: EmpLanguage L} {empAX: EmpAxiomatization L Gamma} {nssGamma: NonsplitEmpSeparationLogic L Gamma} x y,
  |-- x * y && emp --> y.
Proof.
  intros.
  rewrite sepcon_comm.
  apply emp_sepcon_elim1.
Qed.

End WandRules.


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

(** * Tight typing ⊢#] *)

Set Implicit Arguments.

Require Import Coq.Program.Equality.
Require Import Definitions PreciseTyping.

Reserved Notation "G '⊢#' t ':' T" (at level 40, t at level 59).
Reserved Notation "G '⊢#' T '<:' U" (at level 40, T at level 59).

(** Tight typing is very similar to general typing, and could be obtained by replacing
    all occurrences of [⊢] with [⊢#], except for the following:
    - in the type selection subtyping rules Sel-<: and <:-Sel ([subtyp_sel1], [subtyp_sel2])
      the premise is precise typing of a type declaration with equal bounds;
    - in the singleton subtyping rules Sngl-<: and <:-Sngl ([subtyp_sngl_pq], and [subtyp_sngl_qp])
      the premise is precise typing;
    - whenever a typing judgement in a premise extends the environment (for example, [ty_all_intro_t]),
      it is typed under general typing [⊢] and not tight typing [⊢#]. *)

Inductive ty_trm_t : ctx -> trm -> typ -> Prop :=

(** [G(x) = T]   #
#
    [――――――――――] #
#
    [G ⊢# x: T]  *)
| ty_var_t : forall G x T,
    binds x T G ->
    G ⊢# tvar x : T

(** [G, x: T ⊢ t^x: U^x]       #
#
    [x fresh]                  #
#
    [――――――――――――――――――――――――] #
#
    [G ⊢# lambda(T)t: forall(T)U]     *)
| ty_all_intro_t : forall G t T U L,
    (forall x, x \notin L ->
      G & x ~ T ⊢ open_trm x t : open_typ x U) ->
    G ⊢# trm_val (λ(T) t) : ∀(T) U

(** [G ⊢# p: forall(S)T]  #
#
    [G ⊢# q: S]      #
#
    [―――――――――――――――] #
#
    [G ⊢ p q: T^q]    *)
| ty_all_elim_t : forall G p q S T,
    G ⊢# trm_path p : ∀(S) T ->
    G ⊢# trm_path q : S ->
    G ⊢# trm_app p q : open_typ_p q T

(** [z; G, z: T^z ⊢ ds^z :: T^z]    #
#
    [z fresh]                          #
#
    [―――――――――――――――――――――――――――――――]  #
#
    [G ⊢# nu(T)ds :: mu(T)]             *)
| ty_new_intro_t : forall G ds T L,
    (forall z, z \notin L ->
      z; nil; G & (z ~ open_typ z T) ⊢ open_defs z ds :: open_typ z T) ->
    G ⊢# trm_val (ν(T) ds) : μ T

(** [G ⊢# p: {a: T}] #
#
    [―――――――――――――]   #
#
    [G ⊢# p.a: T]        *)
| ty_new_elim_t : forall G p a T,
    G ⊢# trm_path p : typ_rcd {a ⦂ T} ->
    G ⊢# trm_path p • a : T

(** [G ⊢# p.a: T]      #
#
    [――――――――――――――]   #
#
    [G ⊢# p: {a: T}]        *)
| ty_rec_intro_t : forall G p a T,
    G ⊢# trm_path p•a : T ->
    G ⊢# trm_path p : typ_rcd { a ⦂ T }

(** [G ⊢# t: T]             #
#
    [G, x: T ⊢ u^x: U]       #
#
    [x fresh]                #
#
    [――――――――――――――――]       #
#
    [G ⊢# let t in u: U]        *)
| ty_let_t : forall G t u T U L,
    G ⊢# t : T ->
    (forall x, x \notin L ->
      G & x ~ T ⊢ open_trm x u : U) ->
    G ⊢# trm_let t u : U

(** [G ⊢# p: q.type]  #
#
    [G ⊢# q]          #
#
    [―――――――――――――――] #
#
    [G ⊢# p: T]            *)
| ty_sngl_t : forall G p q T,
    G ⊢# trm_path p : {{ q }} ->
    G ⊢# trm_path q : T ->
    G ⊢# trm_path p : T

(** [G ⊢# p.: T]       #
#
    [――――――――――――――]   #
#
    [G ⊢# p: {a: T}]        *)
| ty_path_elim_t : forall G p q a T,
    G ⊢# trm_path p : {{ q }} ->
    G ⊢# trm_path q • a : T ->
    G ⊢# trm_path p • a : {{ q•a }}

(** [G ⊢# p: T^p]   #
#
    [――――――――――――] #
#
    [G ⊢# p: mu(T)]     *)
| ty_rcd_intro_t : forall G p T,
    G ⊢# trm_path p : open_typ_p p T ->
    G ⊢# trm_path p : μ T

(** [G ⊢# p: mu(T)] #
#
    [――――――――――――] #
#
    [G ⊢# p: T^p]   *)
| ty_rec_elim_t : forall G p T,
    G ⊢# trm_path p : μ T ->
    G ⊢# trm_path p : open_typ_p p T

(** [G ⊢# p: T]     #
#
    [G ⊢# p: U]     #
#
    [――――――――――――] #
#
    [G ⊢# p: T /\ U]     *)
| ty_and_intro_t : forall G p T U,
    G ⊢# trm_path p : T ->
    G ⊢# trm_path p : U ->
    G ⊢# trm_path p : T ∧ U

(** [G ⊢# t: T]    #
#
    [G ⊢# T <: U]  #
#
    [―――――――――――――] #
#
    [G ⊢# t: U]        *)
| ty_sub_t : forall G t T U,
    G ⊢# t : T ->
    G ⊢# T <: U ->
    G ⊢# t : U
where "G '⊢#' t ':' T" := (ty_trm_t G t T)

(** *** Tight subtyping [G ⊢# T <: U] *)
with subtyp_t : ctx -> typ -> typ -> Prop :=

(** [G ⊢# T <: top] *)
| subtyp_top_t: forall G T,
    G ⊢# T <: ⊤

(** [G ⊢# bot <: T] *)
| subtyp_bot_t: forall G T,
    G ⊢# ⊥ <: T

(** [G ⊢# T <: T] *)
| subtyp_refl_t: forall G T,
    G ⊢# T <: T

(** [G ⊢# S <: T]     #
#
    [G ⊢# T <: U]     #
#
    [―――――――――――――]    #
#
    [G ⊢# S <: U]         *)
| subtyp_trans_t: forall G S T U,
    G ⊢# S <: T ->
    G ⊢# T <: U ->
    G ⊢# S <: U

(** [G ⊢# T /\ U <: T] *)
| subtyp_and11_t: forall G T U,
    G ⊢# T ∧ U <: T

(** [G ⊢# T /\ U <: U] *)
| subtyp_and12_t: forall G T U,
    G ⊢# T ∧ U <: U

(** [G ⊢# S <: T]       #
#
    [G ⊢# S <: U]       #
#
    [――――――――――――――――]   #
#
    [G ⊢# S <: T /\ U]       *)
| subtyp_and2_t: forall G S T U,
    G ⊢# S <: T ->
    G ⊢# S <: U ->
    G ⊢# S <: T ∧ U

(** [G ⊢# T <: U]           #
#
    [――――――――――――――――――――――] #
#
    [G ⊢# {a: T} <: {a: U}]     *)
| subtyp_fld_t: forall G T U a,
    G ⊢# T <: U ->
    G ⊢# typ_rcd {a ⦂ T} <: typ_rcd {a ⦂ U}

(** [G ⊢# S2 <: S1]                   #
#
    [G ⊢# T1 <: T2]                   #
#
    [――――――――――――――――――――――――――――――――] #
#
    [G ⊢# {A: S1..T1} <: {A: S2..T2}]     *)
| subtyp_typ_t: forall G S1 S2 T1 T2 A,
    G ⊢# S2 <: S1 ->
    G ⊢# T1 <: T2 ->
    G ⊢# typ_rcd { A >: S1 <: T1 } <: typ_rcd { A >: S2 <: T2 }

(** [G ⊢!!! p: q.type]                 #
#
    [G ⊢!!! q: U]                      #
#
    [――――――――――――――――――――――――――――――――] #
#
    [G ⊢# T <: [T[q/p,n]]              *)
| subtyp_sngl_pq_t : forall G p q T T' U,
    G ⊢!!! p : {{ q }} ->
    G ⊢!!! q : U ->
    repl_typ p q T T' ->
    G ⊢# T <: T'

(** [G ⊢!!! p: q.type]                 #
#
    [G ⊢!!! q: U]                      #
#
    [――――――――――――――――――――――――――――――――] #
#
    [G ⊢# T <: [T[p/q,n]]              *)
| subtyp_sngl_qp_t : forall G p q T T' U,
    G ⊢!!! p : {{ q }} ->
    G ⊢!!! q : U ->
    repl_typ q p T T' ->
    G ⊢# T <: T'

(** [G ⊢!!! p: {A: T..T}] #
#
    [―――――――――――――――――――] #
#
    [G ⊢# T <: p.A]         *)
| subtyp_sel2_t: forall G p A T ,
    G ⊢!!! p : typ_rcd { A >: T <: T } ->
    G ⊢# T <: p ↓ A

(** [G ⊢!!! p: {A: T..T}] #
#
    [―――――――――――――――――――] #
#
    [G ⊢# p.A <: T]         *)
| subtyp_sel1_t: forall G p A T,
    G ⊢!!! p : typ_rcd { A >: T <: T } ->
    G ⊢# p↓A <: T

(** [[
G ⊢# ∀(S1)T1 <: ∀(S2)T2
T1 and T2 is non-dependent
S2 is a trivial type
__________________________
G ⊢# T1 <: T2
]]
*)
(* | subtyp_all_inv2 : forall G S1 T1 S2 T2, *)
(*     G ⊢# ∀(S1)T1 <: ∀(S2)T2 -> *)
(*     (forall x, open_typ x T1 = T1) -> *)
(*     (forall x, open_typ x T2 = T2) -> *)
(*     trivial_typ S2 -> *)
(*     G ⊢# T1 <: T2 *)

(** [G ⊢# S2 <: S1]                #
#
    [G, x: S2 ⊢ T1^x <: T2^x]       #
#
    [x fresh]                       #
#
    [――――――――――――――――――――――――]      #
#
    [G ⊢# forall(S1)T1 <: forall(S2)T2]          *)
| subtyp_all_t: forall G S1 S2 T1 T2 L,
    G ⊢# S2 <: S1 ->
    (forall x, x \notin L ->
       G & x ~ S2 ⊢ open_typ x T1 <: open_typ x T2) ->
    G ⊢# ∀(S1) T1 <: ∀(S2) T2

where "G '⊢#' T '<:' U" := (subtyp_t G T U).

Hint Constructors ty_trm_t subtyp_t.

Scheme ts_ty_trm_mut_ts  := Induction for ty_trm_t    Sort Prop
with   ts_subtyp_ts      := Induction for subtyp_t    Sort Prop.
Combined Scheme ts_mutind_ts from ts_ty_trm_mut_ts, ts_subtyp_ts.

(** Tight typing implies general typing. *)
Lemma tight_to_general:
  (forall G t T,
     G ⊢# t : T ->
     G ⊢ t : T) /\
  (forall G S U,
     G ⊢# S <: U ->
     G ⊢ S <: U).
Proof.
  apply ts_mutind_ts; intros; subst; eauto using precise_to_general3.
  Unshelve.
  all: solve_ex_typ_L.
Qed.


Require Import Coq.Lists.List.
Require Import Lia.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Sum.
Require Import Crypto.Util.LetIn.
Require Crypto.Util.ListUtil. (* for tests *)

Section Loops.
  Context {continue_state break_state}
          (body : continue_state -> break_state + continue_state)
          (body_cps : continue_state ->
                  forall {T}, (break_state + continue_state -> T)
                              -> T).

  Definition funapp {A B} (f : A -> B) (x : A) := f x.

  Fixpoint loop_cps (fuel: nat) (start : continue_state)
           {T} (ret : break_state -> T) : continue_state + T :=
    funapp
    (body_cps start _) (fun next =>
                      match next with
                      | inl state => inr (ret state)
                      | inr state =>
                        match fuel with
                        | O => inl state
                        | S fuel' =>
                          loop_cps fuel' state ret
                        end end).

  Fixpoint loop (fuel: nat) (start : continue_state)
    : continue_state + break_state :=
    match (body start) with
    | inl state => inr state
    | inr state =>
      match fuel with
      | O => inl state
      | S fuel' => loop fuel' state
      end end.

  Lemma loop_break_step fuel start state :
    (body start = inl state) ->
    loop fuel start = inr state.
  Proof.
    destruct fuel; simpl loop; break_match; intros; congruence.
  Qed.

  Lemma loop_continue_step fuel start state :
    (body start = inr state) ->
    loop fuel start =
    match fuel with | O => inl state | S fuel' => loop fuel' state end.
  Proof.
    destruct fuel; simpl loop; break_match; intros; congruence.
  Qed.

  (* TODO: provide [invariant state] to proofs of this *)
  Definition progress (measure : continue_state -> nat) :=
    forall state state', body state = inr state' -> measure state' < measure state.
  Definition terminates fuel start := forall l, loop fuel start <> inl l.
  Lemma terminates_by_measure measure (H : progress measure) :
    forall fuel start, measure start <= fuel -> terminates fuel start.
  Proof.
    induction fuel; intros;
      repeat match goal with
             | _ => solve [ congruence | lia ]
             | _ => progress cbv [progress terminates] in *
             | _ => progress cbn [loop]
             | _ => progress break_match
             | H : forall _ _, body _ = inr _ -> _ , Heq : body _ = inr _ |- _ => specialize (H _ _ Heq)
             | _ => eapply IHfuel
    end.
  Qed.

  Definition loop_default fuel start default
    : break_state :=
    sum_rect
      (fun _ => break_state)
      (fun _ => default)
      (fun result => result)
      (loop fuel start).

  Lemma loop_default_eq fuel start default
        (Hterm : terminates fuel start) :
    loop fuel start = inr (loop_default fuel start default).
  Proof.
    cbv [terminates loop_default sum_rect] in *; break_match; congruence.
  Qed.

  Lemma invariant_iff fuel start default (H : terminates fuel start) P :
      P (loop_default fuel start default) <->
      (exists (inv : continue_state -> Prop),
          inv start
          /\ (forall s s', body s = inr s' -> inv s -> inv s')
          /\ (forall s s', body s = inl s' -> inv s -> P s')).
  Proof.
    split;
      [ exists (fun st => exists f e, (loop f st = inr e /\ P e ))
      | destruct 1 as [?[??]]; revert dependent start; induction fuel ];
      repeat match goal with
             | _ => solve [ trivial | congruence | eauto ]
             | _ => progress destruct_head' @ex
             | _ => progress destruct_head' @and
             | _ => progress intros
             | _ => progress cbv [loop_default terminates] in *
             | _ => progress cbn [loop] in *
             | _ => progress erewrite loop_default_eq by eassumption
             | _ => progress erewrite loop_continue_step in * by eassumption
             | _ => progress erewrite loop_break_step in * by eassumption
             | _ => progress break_match_hyps
             | _ => progress break_match
             | _ => progress eexists
             | H1:_, c:_ |- _ => progress specialize (H1 c); congruence
             end.
  Qed.
End Loops.

Definition by_invariant {continue_state break_state body fuel start default}
           invariant measure P invariant_start invariant_continue invariant_break le_start progress
  := proj2 (@invariant_iff continue_state break_state body fuel start default (terminates_by_measure body measure progress fuel start le_start) P)
           (ex_intro _ invariant (conj invariant_start (conj invariant_continue invariant_break))).
Arguments terminates_by_measure {_ _ _}.

Module while.
  Section While.
    Context {state}
            (test : state -> bool)
            (body : state -> state).

    Fixpoint while (fuel: nat) (s : state) {struct fuel} : state :=
      if test s
      then
        let s := body s in
        match fuel with
        | O => s
        | S fuel' => while fuel' s
        end
      else s.

    Section AsLoop.
      Local Definition lbody := fun s => if test s then inr (body s) else inl s.

      Lemma eq_loop : forall fuel start, while fuel start = loop_default lbody fuel start (while fuel start).
      Proof.
        induction fuel; intros;
          cbv [lbody loop_default sum_rect id] in *;
          cbn [while loop]; [|rewrite IHfuel]; break_match; auto.
      Qed.

      Lemma by_invariant fuel start
            (invariant : state -> Prop) (measure : state -> nat) (P : state -> Prop)
            (_: invariant start)
            (_: forall s, invariant s -> if test s then invariant (body s) else P s)
            (_: measure start <= fuel)
            (_: forall s, if test s then measure (body s) < measure s else True)
        : P (while fuel start).
      Proof.
        rewrite eq_loop; cbv [lbody].
        eapply (by_invariant invariant measure);
          repeat match goal with
                 | [ H : forall s, invariant s -> _, G: invariant ?s |- _ ] => unique pose proof (H _ G)
                 | [ H : forall s, if ?f s then _ else _, G: ?f ?s = _ |- _ ] => unique pose proof (H s)
                 | _ => solve [ trivial | congruence ]
                 | _ => progress cbv [progress]
                 | _ => progress intros
                 | _ => progress subst
                 | _ => progress inversion_sum
                 | _ => progress break_match_hyps (* FIXME: this must be last? *)
                 end.
      Qed.
    End AsLoop.
  End While.
  Arguments by_invariant {_ _ _ _ _}.
End while.
Notation while := while.while.

Definition for2 {state} (test : state -> bool) (increment body : state -> state)
  := while test (fun s => increment (body s)).

Definition for3 {state} init test increment body fuel :=
  @for2 state test increment body fuel init.

Module _test.
  Section GCD.
    Definition gcd_step :=
      fun '(a, b) => if Nat.ltb a b
                     then inr (a, b-a)
                     else if Nat.ltb b a
                          then inr (a-b, b)
                          else inl a.

    Definition gcd fuel a b := loop_default gcd_step fuel (a,b) 0.

    (* Eval cbv [gcd loop_default loop gcd_step] in (gcd 10 5 7). *)

    Example gcd_test : gcd 1000 28 35 = 7 := eq_refl.

    Definition gcd_step_cps
      : (nat * nat) -> forall T, (nat + (nat * nat) -> T) -> T
      :=
        fun st T ret =>
          let a := fst st in
          let b := snd st in
          if Nat.ltb a b
          then ret (inr (a, b-a))
          else if Nat.ltb b a
               then ret (inr (a-b, b))
               else ret (inl a).

    Definition gcd_cps fuel a b {T} (ret:nat->T)
      := loop_cps gcd_step_cps fuel (a,b) ret.

    Example gcd_test2 : gcd_cps 1000 28 35 id = inr 7 := eq_refl.

    (* Eval cbv [gcd_cps loop_cps gcd_step_cps id] in (gcd_cps 2 5 7 id). *)

  End GCD.

  (* simple example--set all elements in a list to 0 *)
  Section ZeroLoop.
    Import Crypto.Util.ListUtil.

    Definition zero_body (state : nat * list nat) :
      list nat + (nat * list nat) :=
      if dec (fst state < length (snd state))
      then inr (S (fst state), set_nth (fst state) 0 (snd state))
      else inl (snd state).

    Lemma zero_body_progress (arr : list nat) :
      progress zero_body (fun state : nat * list nat => length (snd state) - fst state).
    Proof.
      cbv [zero_body progress]; intros until 0;
        repeat match goal with
               | _ => progress autorewrite with cancel_pair distr_length
               | _ => progress subst
               | _ => progress break_match; intros
               | _ => congruence
               | H: inl _ = inl _ |- _ => injection H; intros; subst; clear H
               | H: inr _ = inr _ |- _ => injection H; intros; subst ;clear H
               | _ => lia
               end.
    Qed.

    Definition zero_loop (arr : list nat) : list nat :=
      loop_default zero_body (length arr) (0,arr) nil.

    Definition zero_invariant (state : nat * list nat) :=
      fst state <= length (snd state)
      /\ forall n, n < fst state -> nth_default 0 (snd state) n = 0.

    Lemma zero_correct (arr : list nat) :
      forall n, nth_default 0 (zero_loop arr) n = 0.
    Proof.
      intros. cbv [zero_loop].
      eapply (by_invariant zero_invariant); eauto using zero_body_progress;
        [ cbv [zero_invariant]; autorewrite with cancel_pair; split; intros; lia | ..];
        cbv [zero_invariant zero_body];
        intros until 0;
        break_match; intros;
          repeat match goal with
                 | _ => congruence
                 | H: inl _ = inl _ |- _ => injection H; intros; subst; clear H
                 | H: inr _ = inr _ |- _ => injection H; intros; subst ;clear H
                 | _ => progress split
                 | _ => progress intros
                 | _ => progress subst
                 | _ => progress (autorewrite with cancel_pair distr_length in * )
                 | _ => rewrite set_nth_nth_default by lia
                 | _ => progress break_match
                 | H : _ /\ _ |- _ => destruct H
                 | H : (_,_) = ?x |- _ =>
                   destruct x; inversion H; subst; destruct H
                 | H : _ |- _ => apply H; lia
                 | _ => lia
                 end.
      destruct (Compare_dec.lt_dec n (fst s)).
      apply H1; lia.
      apply nth_default_out_of_bounds; lia.
    Qed.
  End ZeroLoop.
End _test.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C Aprime Bprime Cprime : Universe, ((wd_ O Aprime /\ (wd_ O Bprime /\ (wd_ O Cprime /\ (wd_ A B /\ (wd_ A Aprime /\ (wd_ Aprime Bprime /\ (wd_ B C /\ (wd_ B Bprime /\ (wd_ C Cprime /\ (wd_ A C /\ (wd_ O C /\ (wd_ O B /\ (wd_ O A /\ (wd_ B Aprime /\ (wd_ Bprime C /\ (wd_ Aprime C /\ (wd_ Bprime A /\ (col_ O A B /\ (col_ Aprime Bprime Cprime /\ (col_ O Aprime Bprime /\ col_ A B C)))))))))))))))))))) -> col_ O Aprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.