Require Import NArith.
Require Import Word.

(* This module can be instantiated into some concrete ways and some more abstract ways. *)
(* A word can be a tuple of 256 booleans. *)
(* Alternatively a word can be thought of as some abstract values.
 * This would be interesting in bytecode analysis tools.
 *)
(* Many aspects of the EVM semantics do not care how words are represented. *)
Module Make (W : Word).
Export W.

Definition bool_to_word (b : bool) :=
  if b then word_one else word_zero.

Arguments bool_to_word b /.

Open Scope list_scope.

Definition drop_one_element {A : Type} (lst : list A) :=
  match lst with
  | nil => nil
  | _ :: tl => tl
  end.

(***
 *** Some abstract view over EVM
 ***)

(** This part is hugely incomplete.  It misses many instructions and
    gas economy.  They will be added as necessary. *)

(* An element of type [call_arguments] describes
   arguments that an execution can attach to
   [CALL] *)
Record call_arguments :=
    { callarg_gaslimit    : word
    ; callarg_code        : address
    ; callarg_recipient   : address
    ; callarg_value       : word
    ; callarg_data        : list byte
    ; callarg_output_begin : word
    ; callarg_output_size : word
    }.

(* An element of type [return_result] is a sequence of bytes that
   [RETURN] can return. *)
Record return_result :=
  { return_data : list byte;
    return_balance : address -> word
  }.

(* TODO: add something similar to return_balance to
   failures *)

(* An element of type [call_env] describes
   an environment where contract is executed
 *)
Record call_env :=
  { callenv_gaslimit : word
  ; callenv_value : word
  ; callenv_data : list byte
  ; callenv_caller : address
  ; callenv_timestap : word
  ; callenv_blocknum : word
  ; callenv_balance : address -> word
  }.

Inductive contract_action :=
| ContractCall : call_arguments -> contract_action
  (* [Call args continuation] is the behavior of [CALL] instruction
      together with all behaviors shown by the account after the [CALL].
     [args] represents the parameters of a call.
     [continuation] represents the behavior shown after the [CALL]
     instruction.  See the comment at [after_call_behavior].
   *)
| ContractFail : contract_action
  (* [Fail] is the behavior of runtime errors (e.g. jumping to an invalid
     program counter / lack of gas *)
| ContractSuicide : contract_action
| ContractReturn : list byte (* returned data *) -> contract_action.
  (* [Return ret next] is the behavior of a [RETURN], [STOP] instruction.
     Upon the next call with [env], [next env] will be the contract behavior.
   *)

(* An element of type [response_to_world] describes a strategy of a contract
   that can respond when
   1. it is called from the world
   2. it receives a callee return from the world
   3. it receives a callee failure from the world.
   Initially, when the contract has not called any other accounts,
   the points 2. and 3. are useless.
 *)
CoInductive response_to_world :=
| Respond :
    (call_env -> contract_behavior) (* what to do if called / or re-entered *) ->
    (return_result -> contract_behavior) (* what to do if the callee returns (if exists) *) ->
    (contract_behavior) (* what to do if the callee's execution fails *) ->
    response_to_world

(* An element of type [contract_behavior] describes a behavior of an
   already called contract.  A contract has four ways of giving the
   control back to the world.
   1. returning
   2. failing
   3. commiting suicide
   4. calling some account
 *)
with contract_behavior :=
| ContractAction : contract_action -> response_to_world -> contract_behavior
.

(* A useful function for reasoning.
   I was looking at http://adam.chlipala.net/cpdt/html/Coinductive.html
   around [frob].
 *)
Definition contract_action_expander (ca : contract_behavior) :=
  match ca with ContractAction a b => ContractAction a b end.

Definition response_expander (r : response_to_world) :=
  match r with Respond f g h => Respond f g h end.

Lemma contract_action_expander_eq :
  forall ca, contract_action_expander ca = ca.
Proof.
  intro ca.
  case ca.
  auto.
Qed.

Lemma response_expander_eq :
  forall r, r = response_expander r.
Proof.
  intro r.
  case r.
  auto.
Qed.

(********* What the world does on an account ***********)

Inductive world_action :=
| WorldCall : call_env -> world_action
| WorldRet  : return_result -> world_action
| WorldFail : world_action
.

Definition world := list world_action.

(********
 When [world] and [respond_to_world] meet,
 they produce a sequence of events *)

Inductive action :=
| ActionByWorld : world_action -> action
| ActionByContract : contract_action -> action.

Definition history := list action.

(******** World and the contract interact to produce a history ****)

Fixpoint specification_run (w : world) (r : response_to_world) : history :=
  match w, r with
  | nil, _ => nil
  | WorldCall call :: world_cont, Respond f _ _ =>
    match f call with
    | ContractAction cact contract_cont =>
      ActionByWorld (WorldCall call) ::
      ActionByContract cact ::
      specification_run world_cont contract_cont
    end
  | WorldRet ret :: world_cont, Respond _ r _ =>
    match (r ret) with
      ContractAction cact contract_cont =>
      ActionByWorld (WorldRet ret) ::
      ActionByContract cact ::
      specification_run world_cont contract_cont
    end
  | WorldFail :: world_cont, Respond _ _ (ContractAction cact contract_cont) =>
    ActionByWorld WorldFail ::
    ActionByContract cact ::
    specification_run world_cont contract_cont
  end.

(***
 *** Some more concrete view on EVM.
 *** This part is for interpreting bytecodes in terms of the abstract view above.
 ***)

(**
 ** Instructions
 **)

Inductive instruction :=
| PUSH1 : word -> instruction
| PUSH2 : word -> instruction
| PUSH32 : word -> instruction
| SLOAD
| SSTORE
| JUMP
| JUMPI
| JUMPDEST
| CALLDATASIZE
| CALLDATALOAD
| CALLVALUE
| CALLER
| ADD
| SUB
| ISZERO
| CALL
| RETURN
| STOP
| DUP1
| POP
| GASLIMIT
| instr_GT
| instr_EQ
.

(**
 ** Program
 **)

Definition program := list instruction.

Require Import Recdef.

Function drop_bytes (prog : list instruction) (bytes : N)
         :=
  match prog, bytes with
  | _, N0 => prog
  | PUSH1 v :: tl, _ =>
    drop_bytes tl (bytes - 2)
  | PUSH2 v :: tl, _ =>
    drop_bytes tl (bytes - 3)
  | _ :: tl, _ =>
    drop_bytes tl (bytes - 1)
  | nil, _ => nil
  end.

(**
 ** Execution Environments
 **)

Record variable_env :=
  { venv_stack : list word
  ; venv_memory : memory_state
  ; venv_storage : storage
  ; venv_prg_sfx : list instruction
  ; venv_balance : address -> word (* does this blong here?*)
  ; venv_caller : address
  ; venv_value_sent : word
  ; venv_data_sent : list byte
  (* TODO: add the sequence of executed instructions.
     would be useful for calculating the gas *)

  (* These are necessary when throwing. *)
  ; venv_storage_at_call : storage
  ; venv_balance_at_call : address -> word

  (* TODO: use venv_balance_at_call somewhere *)
  }.

(* [update_balance adr v original] is similar to [original] except
   that [adr] is mapped to [v].
*)
Definition update_balance (a : address) (newbal : word -> word)
           (orig : address -> word) : (address -> word) :=
  fun (query : address) =>
    if address_eq a query then newbal (orig query) else orig query.

Lemma get_update_balance :
  forall addr f original,
    update_balance addr f original addr = f (original addr).
Proof.
  intros addr value original.
  unfold update_balance.
  rewrite address_eq_refl.
  auto.
Qed.

Record constant_env :=
  { cenv_program : list instruction;
    cenv_this : address
  }.

(** Initialize variable_env variable_env . *)
Definition init_variable_env (s : storage) (bal : address -> word)
           (caller : address)
           (cenv : constant_env) (value : word) (data : list byte) :=
  {|
    venv_stack := nil ;
    venv_memory := empty_memory ;
    venv_prg_sfx := cenv.(cenv_program) ;
    venv_storage := s ;
    venv_balance := bal ;
    venv_caller := caller ;
    venv_value_sent := value ;
    venv_data_sent := data ;
    venv_storage_at_call := s ;
    venv_balance_at_call := bal ;
  |}.

(**
 **  Meaning of an instruction.
 **)

Inductive instruction_result :=
| InstructionContinue : variable_env -> instruction_result
| InstructionToWorld : contract_action -> option variable_env (* to be pushed into the call stack *) -> instruction_result
| InstructionInvalid : instruction_result (* PUSH1 with more than 255 *)
.

Definition instruction_failure_result :=
  InstructionToWorld ContractFail None.

Definition instruction_return_result (x: list byte) :=
  InstructionToWorld (ContractReturn x) None.

Definition venv_update_stack (new_stack : list word) (v : variable_env) :=
  {|
    venv_stack := new_stack ;
    venv_memory := v.(venv_memory) ;
    venv_storage := v.(venv_storage) ;
    venv_prg_sfx := v.(venv_prg_sfx) ;
    venv_balance := v.(venv_balance) ;
    venv_caller := v.(venv_caller) ;
    venv_value_sent := v.(venv_value_sent) ;
    venv_data_sent := v.(venv_data_sent) ;
    venv_storage_at_call := v.(venv_storage_at_call) ;
    venv_balance_at_call := v.(venv_balance_at_call)
  |}.

Arguments venv_update_stack new_stack v /.

Definition venv_update_balance (new_balance : address -> word) (v : variable_env) :=
  {|
    venv_stack := v.(venv_stack) ;
    venv_memory := v.(venv_memory) ;
    venv_storage := v.(venv_storage) ;
    venv_prg_sfx := v.(venv_prg_sfx) ;
    venv_balance := new_balance ;
    venv_caller := v.(venv_caller) ;
    venv_value_sent := v.(venv_value_sent) ;
    venv_data_sent := v.(venv_data_sent) ;
    venv_storage_at_call := v.(venv_storage_at_call) ;
    venv_balance_at_call := v.(venv_balance_at_call)
  |}.

Definition venv_advance_pc (v : variable_env) :=
  {|
    venv_stack := v.(venv_stack) ;
    venv_memory := v.(venv_memory) ;
    venv_storage := v.(venv_storage) ;
    venv_prg_sfx := drop_one_element v.(venv_prg_sfx) ;
    venv_balance := v.(venv_balance) ;
    venv_caller := v.(venv_caller) ;
    venv_value_sent := v.(venv_value_sent) ;
    venv_data_sent := v.(venv_data_sent) ;
    venv_storage_at_call := v.(venv_storage_at_call) ;
    venv_balance_at_call := v.(venv_balance_at_call)
  |}.

Arguments venv_advance_pc v /.

Require Import List.

Fixpoint venv_pop_stack (n : nat) (v : variable_env) :=
  match n with
  | O => v
  | S m =>
  venv_pop_stack m
    (venv_update_stack
      (tl v.(venv_stack)) v)
  end.

Definition venv_stack_top (v : variable_env) : option word :=
  match v.(venv_stack) with
  | h :: _ => Some h
  | _ => None
  end.

Definition venv_change_sfx (pos : N) (v : variable_env)
  (c : constant_env) : variable_env :=
  {|
    venv_stack := v.(venv_stack) ;
    venv_memory := v.(venv_memory);
    venv_storage := v.(venv_storage);
    venv_prg_sfx := drop_bytes c.(cenv_program) pos ;
    venv_balance := v.(venv_balance);
    venv_caller := v.(venv_caller);
    venv_value_sent := v.(venv_value_sent);
    venv_data_sent := v.(venv_data_sent);
    venv_storage_at_call := v.(venv_storage_at_call) ;
    venv_balance_at_call := v.(venv_balance_at_call)
  |}.

Arguments venv_change_sfx pos v c /.

Definition function_update (addr : word) (val : word) (f : word -> word) : (word -> word) :=
  fun x => (if word_eq x addr then val else f x).

Definition venv_update_storage (idx : word) (val : word) (v : variable_env)
           : variable_env :=
  {|
    venv_stack := v.(venv_stack) ;
    venv_memory := v.(venv_memory);
    venv_storage := storage_store idx val v.(venv_storage);
    venv_prg_sfx := v.(venv_prg_sfx);
    venv_balance := v.(venv_balance);
    venv_caller := v.(venv_caller);
    venv_value_sent := v.(venv_value_sent);
    venv_data_sent := v.(venv_data_sent);
    venv_storage_at_call := v.(venv_storage_at_call) ;
    venv_balance_at_call := v.(venv_balance_at_call)
  |}.

Definition venv_update_whole_storage (new_storage : storage) (v : variable_env)
           : variable_env :=
  {|
    venv_stack := v.(venv_stack) ;
    venv_memory := v.(venv_memory);
    venv_storage := new_storage;
    venv_prg_sfx := v.(venv_prg_sfx);
    venv_balance := v.(venv_balance);
    venv_caller := v.(venv_caller);
    venv_value_sent := v.(venv_value_sent);
    venv_data_sent := v.(venv_data_sent);
    venv_storage_at_call := v.(venv_storage_at_call) ;
    venv_balance_at_call := v.(venv_balance_at_call)
  |}.

Definition venv_first_instruction (v : variable_env) : option instruction :=
  hd_error v.(venv_prg_sfx).

(** a general functoin for defining an instruction that
    pushes one element to the stack *)

Definition stack_0_0_op (v : variable_env) (c : constant_env)
  : instruction_result :=
  InstructionContinue (venv_advance_pc v).

Definition stack_0_1_op (v : variable_env) (c : constant_env) (w : word) : instruction_result :=
  InstructionContinue
    (venv_advance_pc (venv_update_stack (w :: v.(venv_stack)) v)).

(* These are just assumed for my laziness. *)
Definition stack_1_1_op (v: variable_env) (c : constant_env)
                    (f : word -> word) : instruction_result :=
  match v.(venv_stack) with
    | nil => instruction_failure_result
    | h :: t =>
      InstructionContinue
        (venv_advance_pc (venv_update_stack (f h :: t) v))
  end.

Definition stack_1_2_op (v: variable_env) (c : constant_env)
           (f : word -> (word (* new head *) * word (* new second*) ))
  : instruction_result :=
  match v.(venv_stack) with
    | nil => instruction_failure_result
    | h :: t =>
      match f h with
        (new0, new1) =>
        InstructionContinue
          (venv_advance_pc (venv_update_stack (new0 :: new1 :: t) v))
      end
  end.

Definition stack_2_1_op (v : variable_env) (c : constant_env)
                    (f : word -> word -> word) : instruction_result :=
  match v.(venv_stack) with
    | operand0 :: operand1 :: rest =>
      InstructionContinue (venv_advance_pc
                             (venv_update_stack (f operand0 operand1 :: rest) v))
    | _ => instruction_failure_result
  end.

Definition sload (v : variable_env) (idx : word) : word :=
  storage_load idx v.(venv_storage).

Arguments sload v idx /.

Definition sstore (v : variable_env) (c : constant_env) : instruction_result :=
  match v.(venv_stack) with
    | addr :: val :: stack_tail =>
      InstructionContinue
        (venv_advance_pc
           (venv_update_stack stack_tail
                              (venv_update_storage addr val v)))
    | _ => instruction_failure_result
  end.

Definition jump (v : variable_env) (c : constant_env) : instruction_result :=
  match venv_stack_top v with
  | None => instruction_failure_result
  | Some pos =>
    let v_new := venv_change_sfx (N_of_word pos) (venv_pop_stack 1 v) c in
    match venv_first_instruction v_new with
    | Some JUMPDEST =>
        InstructionContinue v_new
    | _ => instruction_failure_result
    end
  end.

Arguments jump v c /.

Definition jumpi (v : variable_env) (c : constant_env) : instruction_result :=
  match v.(venv_stack) with
  | pos :: cond :: rest =>
    if word_iszero cond then
      InstructionContinue (venv_advance_pc (venv_pop_stack 2 v))
    else
      jump (venv_update_stack (pos :: rest) v) c (* this has to change when gas is considered  *)
  | _ => instruction_failure_result
  end.

Arguments jumpi v c /.

Definition datasize (v : variable_env) : word :=
  word_of_nat (List.length v.(venv_data_sent)).

Axiom list_slice : N -> N -> list byte -> word.

Definition cut_data (v : variable_env) (idx: word) : word :=
  list_slice (N_of_word idx) 32 v.(venv_data_sent).

(* currently this is not very true: to fix, add the sequence of executed instructions in venv. *)
Axiom gas_limit : variable_env -> word.

(* TODO: this should fail for various reasons.  lack of balance. *)
Definition call (v : variable_env) (c : constant_env) : instruction_result :=
  match v.(venv_stack) with
  | e0 :: e1 :: e2 :: e3 :: e4 :: e5 :: e6 :: rest =>
    if word_smaller (v.(venv_balance) (c.(cenv_this))) e2 then
      InstructionToWorld ContractFail None
    else
    InstructionToWorld
      (ContractCall
         {|
           callarg_gaslimit := e0 ;
           callarg_code := address_of_word e1 ;
           callarg_recipient := address_of_word e1 ;
           callarg_value := e2 ;
           callarg_data := cut_memory e3 e4 v.(venv_memory) ;
           callarg_output_begin := e5 ;
           callarg_output_size := e6 ;
         |})
      (Some (* TODO: this part should be abstracted away *)
         {|
           venv_stack := rest;
           venv_memory := v.(venv_memory);
           venv_storage := v.(venv_storage);
           venv_prg_sfx := drop_one_element (v.(venv_prg_sfx));
           venv_balance :=
             (* This is dealt in build_venv_called.
                (update_balance (address_of_word e1)
                             (fun orig => word_add orig e2) *)
             (update_balance c.(cenv_this)
                (fun orig => word_sub orig e2) v.(venv_balance));
           venv_caller := v.(venv_caller);
           venv_value_sent := v.(venv_value_sent) ;
           venv_data_sent := v.(venv_data_sent) ;
           venv_storage_at_call := v.(venv_storage_at_call) ;
           venv_balance_at_call := v.(venv_balance_at_call)
         |}
      )
  | _ =>
    InstructionToWorld ContractFail None (* this environment should disappear *)
  end.

Arguments call v c /.

Definition venv_returned_bytes v :=
  match v.(venv_stack) with
    | e0 :: e1 :: _ => cut_memory e0 e1 (v.(venv_memory))
    | _ => nil
  end.

Arguments venv_returned_bytes v /.

Definition ret (v : variable_env) (c : constant_env) : instruction_result :=
  InstructionToWorld (ContractReturn (venv_returned_bytes v) )
                     None.

Definition stop (v : variable_env) (c : constant_env) : instruction_result :=
  InstructionToWorld (ContractReturn nil)
                     None.

Definition pop (v : variable_env) (c : constant_env) : instruction_result :=
  InstructionContinue
    (venv_advance_pc (venv_update_stack
       (tail v.(venv_stack))
       v)).

Require Import Coq.Program.Basics.

Definition instruction_sem (v : variable_env) (c : constant_env) (i : instruction)
  : instruction_result :=
  match i with
  | PUSH1 w =>
    stack_0_1_op v c (word_mod w (word_of_N 256%N))
  | PUSH2 w =>
    stack_0_1_op v c (word_mod w (word_mul (word_of_N 256%N) (word_of_N 256%N)))
  | PUSH32 w =>
    stack_0_1_op v c w
  | SLOAD => stack_1_1_op v c (sload v)
  | SSTORE => sstore v c
  | JUMPI => jumpi v c
  | JUMP => jump v c
  | JUMPDEST => stack_0_0_op v c
  | CALLDATASIZE => stack_0_1_op v c (datasize v)
  | CALLDATALOAD => stack_1_1_op v c (cut_data v)
  | CALLVALUE => stack_0_1_op v c v.(venv_value_sent)
  | CALLER => stack_0_1_op v c (word_of_address v.(venv_caller))
  | ADD => stack_2_1_op v c word_add
  | SUB => stack_2_1_op v c word_sub
  | ISZERO => stack_1_1_op v c (compose bool_to_word word_iszero)
  | CALL => call v c
  | RETURN => ret v c
  | STOP => stop v c
  | DUP1 => stack_1_2_op v c (fun a => (a, a))
  | POP => pop v c
  | GASLIMIT => stack_0_1_op v c (gas_limit v)
  | instr_GT => stack_2_1_op v c (fun a b => bool_to_word (word_smaller b a))
  | instr_EQ => stack_2_1_op v c (fun a b => bool_to_word (word_eq a b))
  end.

Inductive program_result :=
| ProgramStepRunOut : program_result
| ProgramToWorld : contract_action ->
                   storage (* updated storage *) ->
                   (address -> word) (* updated balance *) ->
                   option variable_env (* to be pushed in the call stack *) -> program_result
| ProgramInvalid : program_result
.

Fixpoint program_sem (v : variable_env) (c :constant_env) (steps : nat)
  : program_result :=
  match steps with
    | O => ProgramStepRunOut
    | S remaining_steps =>
      match v.(venv_prg_sfx) with
      | nil => ProgramToWorld ContractFail v.(venv_storage_at_call) v.(venv_balance_at_call) None
      | i :: _ =>
        match instruction_sem v c i with
        | InstructionContinue new_v =>
          program_sem new_v c remaining_steps
        | InstructionToWorld ContractFail opt_pushed_v =>
          ProgramToWorld ContractFail v.(venv_storage_at_call) v.(venv_balance_at_call) opt_pushed_v
        | InstructionToWorld (ContractCall args) (Some new_v) =>
          ProgramToWorld (ContractCall args) new_v.(venv_storage) new_v.(venv_balance) (Some new_v)
        | InstructionToWorld a opt_pushed_v =>
          ProgramToWorld a v.(venv_storage) v.(venv_balance) opt_pushed_v
        (* TODO: change the balance when suicide *)
        | InstructionInvalid => ProgramInvalid
        end
      end
  end.

(****** This program semantics has to be lifted to a history *****)

Record account_state :=
  { account_address : address
  ; account_storage : storage
  ; account_code : list instruction
  ; account_balance : word
    (* this duplicates from the global balance function, but this field
       is necessary for writing invariants involving the balance.
       The balance of the account does not change unless it is called.
     *)
  ; account_ongoing_calls : list variable_env
  }.

Definition account_state_update_storage new_st orig :=
  {| account_address := orig.(account_address);
     account_code    := orig.(account_code);
     account_storage := new_st;
     account_balance := orig.(account_balance);
     account_ongoing_calls := orig.(account_ongoing_calls)
  |}.

Arguments account_state_update_storage new_st orig /.

(** The ideas is that an account state defines a response_to_world **)

Definition build_venv_called (a : account_state) (env : call_env) :
  variable_env :=
  {|
      venv_stack := nil ;
      venv_memory := empty_memory;
      venv_prg_sfx := a.(account_code) ;
      venv_storage := a.(account_storage) ;
      venv_balance :=
        update_balance a.(account_address)
                           (fun _ => (word_add a.(account_balance) env.(callenv_value)))
                           env.(callenv_balance) ;
      venv_caller := env.(callenv_caller) ;
      venv_value_sent := env.(callenv_value) ;
      venv_data_sent := env.(callenv_data) ;
      venv_storage_at_call := a.(account_storage) ;
      venv_balance_at_call :=
        (* although there shouldn't be an update,
         * the environment cannot change the account's balance.
         * this 'update_balance' should be a NO-OP
         *)
        update_balance a.(account_address)
                           (fun _ => a.(account_balance))
                           env.(callenv_balance) ;
    |}.

Arguments build_venv_called a env /.

Definition build_cenv (a : account_state) :
    constant_env :=
    {|
      cenv_program := a.(account_code) ;
      cenv_this := a.(account_address)
   |}.

(* TODO: update the storage according to a *)
(* TODO: udpate the balance according to return_result *)
Definition build_venv_returned
  (a : account_state) (r : return_result) : option variable_env :=
  match a.(account_ongoing_calls) with
  | nil => None
  | recovered :: _ =>
    Some
      (venv_update_whole_storage a.(account_storage)
      (venv_update_balance
         (update_balance a.(account_address) (fun _ => a.(account_balance)) r.(return_balance))
      (venv_update_stack (word_one :: recovered.(venv_stack))
                         recovered)))
         (* TODO: actually, need to update the memory *)
  end.

Arguments build_venv_returned a r /.

(* Since the callee failed, the balance should not be updated. *)
Definition build_venv_fail
           (a : account_state) : option variable_env :=
  match a.(account_ongoing_calls) with
  | nil => None
  | recovered :: _ =>
    Some
      (* TODO: the balance should be recovered.
       * When a call fails, the sent-along value
       * should be returned.
       *)
      (venv_update_stack (word_zero :: recovered.(venv_stack)) recovered)
  end.

Arguments build_venv_fail a /.

Definition account_state_pop_ongoing_call (orig : account_state) :=
  {| account_address := orig.(account_address);
     account_storage := orig.(account_storage);
     account_code := orig.(account_code);
     account_balance := orig.(account_balance);
     account_ongoing_calls := tail (orig.(account_ongoing_calls))
  |}.

Arguments account_state_pop_ongoing_call orig /.

(* TODO: use venv widely and remove other arguments *)
Definition update_account_state (prev : account_state) (act: contract_action)
           (st : storage) (bal : address -> word)
           (v_opt : option variable_env) : account_state :=
        match v_opt with
        | None =>
          {|
            account_address := prev.(account_address) ;
            account_storage := st ;
            account_balance := bal (prev.(account_address));
            account_code := prev.(account_code) ;
            account_ongoing_calls := prev.(account_ongoing_calls)
          |}
        | Some pushed =>
          {|
            account_address := prev.(account_address) ;
            account_storage := st ;
            account_balance := bal (prev.(account_address));
            account_code := prev.(account_code) ;
            account_ongoing_calls := pushed :: prev.(account_ongoing_calls)
          |}
        end.

Definition program_goes_to_world_and (r : program_result) P :=
  match r with
  | ProgramStepRunOut => True
  | ProgramToWorld act st bal pushed_venv =>
    P act st bal pushed_venv
  | _ => False
  end.

Definition respond_to_call_correctly c a I account_state_responds_to_world :=
      forall (callenv : call_env)
          act continuation,
          I (build_venv_called a callenv) (build_cenv a) /\
          (I (build_venv_called a callenv) (build_cenv a) ->
           c callenv = ContractAction act continuation ->
           forall steps,
               let r := program_sem (build_venv_called a callenv) (build_cenv a) steps in
               r = ProgramStepRunOut \/
               exists st, exists bal, exists pushed_venv,
                       r = ProgramToWorld act st bal pushed_venv /\
                       account_state_responds_to_world
                         (account_state_update_storage st (update_account_state a act st bal pushed_venv))
                         continuation I).

Check respond_to_call_correctly.

Definition respond_to_return_correctly (r : return_result -> contract_behavior)
           (a : account_state) (I :variable_env -> constant_env -> Prop)
           account_state_responds_to_world :=
  forall (rr : return_result) venv continuation act,
     Some venv = build_venv_returned a rr ->
     r rr = ContractAction act continuation ->
     (forall steps,
          let r := program_sem venv (build_cenv a) steps in
          r = ProgramStepRunOut \/
          exists pushed_venv, exists st, exists bal,
                  r = ProgramToWorld act st bal pushed_venv /\
                  account_state_responds_to_world
                    (update_account_state (account_state_pop_ongoing_call a) act st bal pushed_venv)
                    continuation I).

Definition respond_to_fail_correctly (f : contract_behavior)
           (a : account_state) (I : variable_env -> constant_env -> Prop)
           account_state_responds_to_world :=
  forall venv continuation act,
     Some venv = build_venv_fail a ->
     f = ContractAction act continuation ->
     forall steps,
       let r := (program_sem venv (build_cenv a) steps) in
       r = ProgramStepRunOut \/
       exists pushed_venv, exists st, exists bal,
               r = ProgramToWorld act st bal pushed_venv /\
               account_state_responds_to_world
                 (update_account_state (account_state_pop_ongoing_call a) act st bal pushed_venv)
                 continuation I.

CoInductive account_state_responds_to_world :
  account_state -> response_to_world -> (variable_env -> constant_env -> Prop (*invariant*)) -> Prop :=
| AccountStep :
    forall (a : account_state)
           (c : call_env -> contract_behavior)
           (r : return_result -> contract_behavior)
           (I : variable_env -> constant_env -> Prop)
           f,
      respond_to_call_correctly c a I account_state_responds_to_world ->
      respond_to_return_correctly r a I account_state_responds_to_world ->
      respond_to_fail_correctly f a I account_state_responds_to_world ->
    account_state_responds_to_world a (Respond c r f) I
.

End Make.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Lists.List.

Class Monad(M: Type -> Type) := mkMonad {
  Bind: forall {A B}, M A -> (A -> M B) -> M B;
  Return: forall {A}, A -> M A;

  left_identity: forall {A B} (a: A) (f: A -> M B),
    Bind (Return a) f = f a;
  right_identity: forall {A} (m: M A),
    Bind m Return = m;
  associativity: forall {A B C} (m: M A) (f: A -> M B) (g: B -> M C),
    Bind (Bind m f) g = Bind m (fun x => Bind (f x) g)
}.

Notation "x <- m1 ; m2" := (Bind m1 (fun x => m2))
  (right associativity, at level 60) : monad_scope.
Notation "m1 ;; m2" := (Bind m1 (fun _ => m2))
  (right associativity, at level 60) : monad_scope.

Open Scope monad_scope.

Instance option_Monad: Monad option := {|
  Bind := fun {A B: Type} (o: option A) (f: A -> option B) => match o with
          | Some x => f x
          | None => None
          end;
  Return := fun {A: Type} (a: A) => Some a
|}.
- intros. reflexivity.
- intros. destruct m; reflexivity.
- intros. destruct m; reflexivity.
Defined.

(* Monad which also supports failure (mzero) and choice (mplus), typically used to chose
   the first successful one *)
Class MonadPlus(M: Type -> Type){MM: Monad M} := mkMonadPlus {
  mzero: forall {A}, M A;
  mplus: forall {A}, M A -> M A -> M A;

  mzero_left: forall {A} (f: A -> M A), Bind mzero f = mzero;
  mzero_right: forall {A B} (v: M A), Bind v (fun (_: A) => @mzero B) = @mzero B;
  mplus_assoc: forall {A} (m1 m2 m3: M A), mplus m1 (mplus m2 m3) = mplus (mplus m1 m2) m3;
}.

Definition msum{A}{M: Type -> Type}{MM: Monad M}{MP: MonadPlus M}: list (M A) -> M A :=
  fold_right mplus mzero.

Instance OptionMonadPlus: MonadPlus option := {|
  mzero := @None;
  mplus A m1 m2 := match m1 with
                   | Some x => m1
                   | None => m2
                   end;
|}.
- intros. reflexivity.
- intros. destruct v; reflexivity.
- intros. destruct m1; reflexivity.
Defined.

Definition State(S A: Type) := S -> (A * S).

Instance State_Monad(S: Type): Monad (State S) := {|
  Bind := fun {A B: Type} (m: State S A) (f: A -> State S B) =>
            fun (s: S) => let (a, s') := m s in f a s' ;
  Return := fun {A: Type} (a: A) =>
              fun (s: S) => (a, s)
|}.
- intros. reflexivity.
- intros. extensionality s. destruct (m s). reflexivity.
- intros. extensionality s. destruct (m s). reflexivity.
Defined.

Module StateM.
Definition get{S: Type}: State S S := fun (s: S) => (s, s).
Definition gets{S A: Type}(f: S -> A): State S A := fun (s: S) => (f s, s).
Definition put{S: Type}(s: S): State S unit := fun _ => (tt, s).
End StateM.

(*
Inductive StateOutcome(S A: Type) :=
| Success: S -> A -> StateOutcome S A
| Break: S -> StateOutcome S A
| Unhandled: StateOutcome S A.

Definition OState(S A: Type) := S -> StateOutcome S A.

Instance OState_Monad(S: Type): Monad (OState S) := {|
  Bind := fun {A B: Type} (m: OState S A) (f: A -> OState S B) =>
            fun (s: S) => match m s with
              | Success _ _ s' a => f a s'
              | Break _ _ s' => Break S B s'
              | Unhandled _ _ => Unhandled S B
              end;
  Return := fun {A: Type} (a: A) =>
              fun (s: S) => Success S A s a
|}.
- intros. reflexivity.
- intros. extensionality s. destruct (m s); reflexivity.
- intros. extensionality s. destruct (m s); reflexivity.
Defined.

Instance OState_MonadPlus(S: Type): MonadPlus (OState S) := {|
  mzero A s := Unhandled S A;
  mplus A m1 m2 s := match m1 s with
    | Success _ _ s' a => Success _ _ s' a
    | Break _ _ s' => Break _ _ s'
    | Unhandled _ _ => m2 s
    end
|}.
- intros. reflexivity.
- intros. Close Scope monad_scope.
  unfold Bind, OState_Monad.
  extensionality s. destruct (v s); try reflexivity.
  (* Note: does not hold: If after break, we find out that actually it's unhandled,
     it's still break, because after break, nothing more is run. *)
Abort.

Definition get{S: Type}: OState S S := fun (s: S) => Some (s, s).
Definition gets{S A: Type}(f: S -> A): OState S A := fun (s: S) => Some (f s, s).
Definition put{S: Type}(s: S): OState S unit := fun _ => Some (tt, s).

*)

(* Note: This one is not what we want either, because it throws away all the state
   on endCycle/raiseException:

Definition OState(S A: Type) := S -> option (A * S).

Instance OState_Monad(S: Type): Monad (OState S) := {|
  Bind := fun {A B: Type} (m: OState S A) (f: A -> OState S B) =>
            fun (s: S) => match m s with
            | Some (a, s') => f a s'
            | None => None
            end;
  Return := fun {A: Type} (a: A) =>
              fun (s: S) => Some (a, s)
|}.
- intros. reflexivity.
- intros. extensionality s. destruct (m s); [|reflexivity]. destruct p. reflexivity.
- intros. extensionality s. destruct (m s); [|reflexivity]. destruct p. reflexivity.
Defined.

Instance OState_MonadPlus(S: Type): MonadPlus (OState S) := {|
  mzero A s := @None (A * S);
  mplus A m1 m2 s := match m1 s with
    | Some p => Some p
    | None => m2 s
    end;
|}.
- intros. reflexivity.
- intros. simpl. extensionality s. destruct (v s); [|reflexivity]. destruct p. reflexivity.
- intros. extensionality s. destruct (m1 s); reflexivity.
Defined.

Definition get{S: Type}: OState S S := fun (s: S) => Some (s, s).
Definition gets{S A: Type}(f: S -> A): OState S A := fun (s: S) => Some (f s, s).
Definition put{S: Type}(s: S): OState S unit := fun _ => Some (tt, s).
 *)

(* Note: This one is not what we want because in "mplus m1 m2", if m1 throws an exception,
   m2 is run, instead of keeping m1's exception.
   The problem is that "None" can mean both "unhandled, please try next" or
   "handled, but exception"
*)
Definition OState(S A: Type) := S -> (option A) * S.

Instance OState_Monad(S: Type): Monad (OState S) := {|
  Bind := fun {A B: Type} (m: OState S A) (f: A -> OState S B) =>
            fun (s: S) => match m s with
            | (Some a, s') => f a s'
            | (None, s') => (None, s')
            end;
  Return := fun {A: Type} (a: A) =>
              fun (s: S) => (Some a, s)
|}.
- intros. reflexivity.
- intros. extensionality s. destruct (m s). destruct o; reflexivity.
- intros. extensionality s. destruct (m s). destruct o; reflexivity.
Defined.

(* TODO if we want to use MonadPlus, we'd have to define a custom equivalence on
   the state monad which only considers A, but not S *)
Axiom OStateEq_to_eq: forall {S A: Type} (s1 s2: S) (a1 a2: option A),
  a1 = a2 -> (a1, s1) = (a2, s2).

Instance OState_MonadPlus(S: Type): MonadPlus (OState S) := {|
  mzero A s := (@None A, s);
  mplus A m1 m2 s := match m1 s with
    | (Some a, s') => (Some a, s')
    | (None, s') => m2 s
    end;
|}.
- intros. reflexivity.
- intros. simpl. extensionality s. destruct (v s).
  destruct o; apply OStateEq_to_eq; reflexivity.
- intros. simpl. extensionality s. destruct (m1 s). destruct o; reflexivity.
Defined.

Definition get{S: Type}: OState S S := fun (s: S) => (Some s, s).
Definition gets{S A: Type}(f: S -> A): OState S A := fun (s: S) => (Some (f s), s).
Definition put{S: Type}(s: S): OState S unit := fun _ => (Some tt, s).

Definition execState{S A: Type}(m: OState S A)(initial: S): S :=
  snd (m initial).

(* T for transformer, corresponds to Haskell's MaybeT: *)
Definition optionT(M: Type -> Type)(A: Type) := M (option A).

Instance OptionT_is_Monad(M: Type -> Type){MM: Monad M}: Monad (optionT M) := {|
  Bind{A}{B}(m: M (option A))(f: A -> M (option B)) :=
    Bind m (fun (o: option A) =>
      match o with
      | Some a => f a
      | None => Return None
      end);
  Return{A}(a: A) := Return (Some a);
|}.
- intros. rewrite left_identity. reflexivity.
- intros. rewrite <- right_identity. f_equal. extensionality o. destruct o; reflexivity.
- intros. rewrite associativity. f_equal. extensionality o. destruct o.
  + reflexivity.
  + rewrite left_identity. reflexivity.
Defined.

Lemma discard_left: forall {M : Type -> Type} {MM : Monad M} {A B : Type} (m: M A) (b: B),
  Bind m (fun _  => Return b) = Return b.
Proof.
  intros. (* Note: This does not hold for the state monad! *)
Admitted.

Definition OpSt(S: Type): Type -> Type := optionT (State S).

Definition OpSt_Monad(S: Type): Monad (OpSt S).
  unfold OpSt. apply OptionT_is_Monad. apply State_Monad.
Defined.

Goal forall (S: Type), False. intro S. set (b := @Bind (OpSt S) (OpSt_Monad S)).
Abort.

Instance optionT_is_MonadPlus(M: Type -> Type){MM: Monad M}: MonadPlus (optionT M) := {|
  mzero A := Return None : M (option A);
  mplus A m1 m2 := @Bind _ _ (option A) _ m1 (fun (o1: option A) => match o1 with
    | Some a1 => Return (Some a1)
    | None => m2
    end) : M (option A);
|}.
- intros. simpl. rewrite left_identity. reflexivity.
- intros. simpl.
  transitivity (Bind v (fun o : option A => Return (@None B))).
  + f_equal. extensionality o. destruct o; reflexivity.
  + apply discard_left.
- intros.
  rewrite associativity. f_equal. extensionality o1. destruct o1.
  + rewrite left_identity. reflexivity.
  + reflexivity.
Defined.

Class MonadTrans(T: (Type -> Type) -> (Type -> Type)) := mkMonadTrans {
  lift{M: Type -> Type}{MM: Monad M}{A: Type}: M A -> T M A;
  transformed_monad{M: Type -> Type}{MM: Monad M}: Monad (T M);
  lift_return{M: Type -> Type}{MM: Monad M}{A: Type}:
    forall a: A, lift (Return a) = Return a;
  lift_bind{M: Type -> Type}{MM: Monad M}{A B: Type}:
    forall (m: M A) (f: A -> M B), lift (Bind m f) = Bind (lift m) (fun x => lift (f x));
}.

(* Promote a function to a monad. *)
Definition liftM{M: Type -> Type}{MM: Monad M}{A B: Type}(f: A -> B): M A -> M B :=
  fun m => x <- m; Return (f x).

Instance optionT_is_MonadTrans: MonadTrans optionT := {|
  lift M MM A := liftM Some;
  transformed_monad := OptionT_is_Monad;
|}.
- intros. unfold liftM. simpl. rewrite left_identity. reflexivity.
- intros. unfold liftM. simpl. rewrite? associativity. f_equal. extensionality a.
  rewrite left_identity. reflexivity.
Defined.


From iris.proofmode Require Import tactics.
From iris.program_logic Require Export weakestpre.
From iris.base_logic Require Export invariants.
From F_mu_ref_conc_sub Require Export rules_binary typing.
From iris.algebra Require Import list.
From stdpp Require Import tactics.
Import uPred.

(* HACK: move somewhere else *)
Ltac auto_equiv :=
  (* Deal with "pointwise_relation" *)
  repeat lazymatch goal with
  | |- pointwise_relation _ _ _ _ => intros ?
  end;
  (* Normalize away equalities. *)
  repeat match goal with
  | H : _ ≡{_}≡ _ |-  _ => apply (discrete_iff _ _) in H
  | H : _ ≡ _ |-  _ => apply leibniz_equiv in H
  | _ => progress simplify_eq
  end;
  (* repeatedly apply congruence lemmas and use the equalities in the hypotheses. *)
  try (f_equiv; fast_done || auto_equiv).

Ltac solve_proper ::= (repeat intros ?; simpl; auto_equiv).

Definition logN : namespace := nroot .@ "logN".

(** interp : is a unary logical relation. *)
Section logrel.
  Context `{heapIG Σ, cfgSG Σ}.
  Notation D := (prodO (valO F_mu_ref_conc_lang) (valO F_mu_ref_conc_lang)
                 -n> iProp Σ).
  Implicit Types τi : D.
  Implicit Types Δ : listO D.
  Implicit Types interp : listO D → D.

  Definition interp_expr (τi : listO D -n> D) (Δ : listO D)
      (ee : expr * expr) : iProp Σ := (∀ j K,
    j ⤇ fill K (ee.2) →
    WP ee.1 {{ v, ∃ v', j ⤇ fill K (of_val v') ∗ τi Δ (v, v') }})%I.
  Global Instance interp_expr_ne n :
    Proper (dist n ==> dist n ==> (=) ==> dist n) interp_expr.
  Proof. unfold interp_expr; solve_proper. Qed.

  Program Definition env_lookup (x : var) : listO D -n> D := λne Δ,
    from_option id (cconst False)%I (Δ !! x).
  Solve Obligations with solve_proper.

  Definition interp_top : listO D -n> D := λne Δ ww, True%I.

  Program Definition interp_unit : listO D -n> D := λne Δ ww,
    (⌜ww.1 = UnitV⌝ ∧ ⌜ww.2 = UnitV⌝)%I.
  Solve Obligations with solve_proper_alt.
  Program Definition interp_nat : listO D -n> D := λne Δ ww,
    (∃ n : nat, ⌜ww.1 = #nv n⌝ ∧ ⌜ww.2 = #nv n⌝)%I.
  Solve Obligations with solve_proper.

  Program Definition interp_bool : listO D -n> D := λne Δ ww,
    (∃ b : bool, ⌜ww.1 = #♭v b⌝ ∧ ⌜ww.2 = #♭v b⌝)%I.
  Solve Obligations with solve_proper.

  Program Definition interp_prod
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ ww,
    (∃ vv1 vv2, ⌜ww = (PairV (vv1.1) (vv2.1), PairV (vv1.2) (vv2.2))⌝ ∧
                interp1 Δ vv1 ∧ interp2 Δ vv2)%I.
  Solve Obligations with solve_proper.

  Program Definition interp_sum
      (interp1 interp2 : listO D -n> D) : listO D -n> D := λne Δ ww,
    ((∃ vv, ⌜ww = (InjLV (vv.1), InjLV (vv.2))⌝ ∧ interp1 Δ vv) ∨
     (∃ vv, ⌜ww = (InjRV (vv.1), InjRV (vv.2))⌝ ∧ interp2 Δ vv))%I.
  Solve Obligations with solve_proper.

  Program Definition interp_arrow
          (interp1 interp2 : listO D -n> D) : listO D -n> D :=
    λne Δ ww,
    (□ ∀ vv, interp1 Δ vv →
             interp_expr
               interp2 Δ (App (of_val (ww.1)) (of_val (vv.1)),
                          App (of_val (ww.2)) (of_val (vv.2))))%I.
  Solve Obligations with solve_proper.

  Program Definition interp_forall
      (interp_bound interp : listO D -n> D) : listO D -n> D := λne Δ ww,
    (□ ∀ τi,
          ⌜∀ ww, Persistent (τi ww)⌝ → □ (∀ vv, τi vv -∗ interp_bound Δ vv) →
          interp_expr
            interp (τi :: Δ) (TApp (of_val (ww.1)), TApp (of_val (ww.2))))%I.
  Solve Obligations with solve_proper.

  Program Definition interp_rec1
      (interp : listO D -n> D) (Δ : listO D) (τi : D) : D := λne ww,
    (□ ∃ vv, ⌜ww = (FoldV (vv.1), FoldV (vv.2))⌝ ∧ ▷ interp (τi :: Δ) vv)%I.
  Solve Obligations with solve_proper.

  Global Instance interp_rec1_contractive
    (interp : listO D -n> D) (Δ : listO D) : Contractive (interp_rec1 interp Δ).
  Proof. solve_contractive. Qed.

  Lemma fixpoint_interp_rec1_eq (interp : listO D -n> D) Δ x :
    fixpoint (interp_rec1 interp Δ) x ≡ interp_rec1 interp Δ (fixpoint (interp_rec1 interp Δ)) x.
  Proof. exact: (fixpoint_unfold (interp_rec1 interp Δ) x). Qed.

  Program Definition interp_rec (interp : listO D -n> D) : listO D -n> D := λne Δ,
    fixpoint (interp_rec1 interp Δ).
  Next Obligation.
    intros interp n Δ1 Δ2 HΔ; apply fixpoint_ne => τi ww. solve_proper.
  Qed.

  Program Definition interp_ref_inv (ll : loc * loc) : D -n> iProp Σ := λne τi,
    (∃ vv, ll.1 ↦ᵢ vv.1 ∗ ll.2 ↦ₛ vv.2 ∗ τi vv)%I.
  Solve Obligations with solve_proper.

  Program Definition interp_ref
      (interp : listO D -n> D) : listO D -n> D := λne Δ ww,
    (∃ ll, ⌜ww = (LocV (ll.1), LocV (ll.2))⌝ ∧
           inv (logN .@ ll) (interp_ref_inv ll (interp Δ)))%I.
  Solve Obligations with solve_proper.

  Fixpoint interp (τ : type) : listO D -n> D :=
    match τ return _ with
    | Top => interp_top
    | TUnit => interp_unit
    | TNat => interp_nat
    | TBool => interp_bool
    | TProd τ1 τ2 => interp_prod (interp τ1) (interp τ2)
    | TSum τ1 τ2 => interp_sum (interp τ1) (interp τ2)
    | TArrow τ1 τ2 => interp_arrow (interp τ1) (interp τ2)
    | TVar x => env_lookup x
    | TForall σ τ' => interp_forall (interp σ) (interp τ')
    | TRec τ' => interp_rec (interp τ')
    | Tref τ' => interp_ref (interp τ')
    end.
  Notation "⟦ τ ⟧" := (interp τ).

  Definition interp_env (Γ : list type)
      (Δ : listO D) (vvs : list (val * val)) : iProp Σ :=
    (⌜length Γ = length vvs⌝ ∗ [∗] zip_with (λ τ, ⟦ τ ⟧ Δ) Γ vvs)%I.
  Notation "⟦ Γ ⟧*" := (interp_env Γ).

  Class env_Persistent Δ :=
    env_persistentP : Forall (λ τi, ∀ vv, Persistent (τi vv)) Δ.
  Global Instance env_persistent_nil : env_Persistent [].
  Proof. by constructor. Qed.
  Global Instance env_persistent_cons τi Δ :
    (∀ vv, Persistent (τi vv)) → env_Persistent Δ → env_Persistent (τi :: Δ).
  Proof. by constructor. Qed.
  Global Instance env_persistent_lookup Δ x vv :
    env_Persistent Δ → Persistent (env_lookup x Δ vv).
  Proof. intros HΔ; revert x; induction HΔ=>-[|?] /=; apply _. Qed.
  Global Instance interp_persistent τ Δ vv :
    env_Persistent Δ → Persistent (⟦ τ ⟧ Δ vv).
  Proof.
    revert vv Δ; induction τ=> vv Δ HΔ; simpl; try apply _.
    rewrite /Persistent fixpoint_interp_rec1_eq /interp_rec1 /= intuitionistically_into_persistently.
    by apply persistently_intro'.
  Qed.
  Global Instance interp_env_base_persistent Δ Γ vs :
  env_Persistent Δ → TCForall Persistent (zip_with (λ τ, ⟦ τ ⟧ Δ) Γ vs).
  Proof.
    intros HΔ. revert vs.
    induction Γ => vs; simpl; destruct vs; constructor; apply _.
  Qed.
  Global Instance interp_env_persistent Γ Δ vvs :
    env_Persistent Δ → Persistent (⟦ Γ ⟧* Δ vvs) := _.

  Lemma interp_weaken Δ1 Π Δ2 τ :
    ⟦ τ.[upn (length Δ1) (ren (+ length Π))] ⟧ (Δ1 ++ Π ++ Δ2)
    ≡ ⟦ τ ⟧ (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Π Δ2. induction τ=> Δ1 Π Δ2; simpl; auto.
    - intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - unfold interp_expr.
      intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - apply fixpoint_proper=> τi ww /=.
      properness; auto. apply (IHτ (_ :: _)).
    - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl.
      { by rewrite !lookup_app_l. }
      (* FIXME: Ideally we wouldn't have to do this kinf of surgery. *)
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia.
    - unfold interp_expr.
      intros ww; simpl; properness; auto. by apply IHτ. by apply (IHτ0 (_ :: _)).
    - intros ww; simpl; properness; auto. by apply IHτ.
  Qed.

  Lemma interp_subst_up Δ1 Δ2 τ τ' :
    ⟦ τ ⟧ (Δ1 ++ interp τ' Δ2 :: Δ2)
    ≡ ⟦ τ.[upn (length Δ1) (τ' .: ids)] ⟧ (Δ1 ++ Δ2).
  Proof.
    revert Δ1 Δ2; induction τ=> Δ1 Δ2; simpl; auto.
    - intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - unfold interp_expr.
      intros ww; simpl; properness; auto. by apply IHτ1. by apply IHτ2.
    - apply fixpoint_proper=> τi ww /=.
      properness; auto. apply (IHτ (_ :: _)).
    - rewrite iter_up; destruct lt_dec as [Hl | Hl]; simpl.
      { by rewrite !lookup_app_l. }
      (* FIXME: Ideally we wouldn't have to do this kinf of surgery. *)
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..].
      case EQ: (x - length Δ1) => [|n]; simpl.
      { symmetry. asimpl. apply (interp_weaken [] Δ1 Δ2 τ'). }
      change (bi_ofeO (uPredI (iResUR Σ))) with (uPredO (iResUR Σ)).
      rewrite !lookup_app_r; [|lia ..]. do 2 f_equiv. lia.
    - unfold interp_expr.
      intros ww; simpl; properness; auto. by apply IHτ. by apply (IHτ0 (_ :: _)).
    - intros ww; simpl; properness; auto. by apply IHτ.
  Qed.

  Lemma interp_subst Δ2 τ τ' v : ⟦ τ ⟧ (⟦ τ' ⟧ Δ2 :: Δ2) v ≡ ⟦ τ.[τ'/] ⟧ Δ2 v.
  Proof. apply (interp_subst_up []). Qed.

  Lemma interp_env_length Δ Γ vvs : ⟦ Γ ⟧* Δ vvs ⊢ ⌜length Γ = length vvs⌝.
  Proof. by iIntros "[% ?]". Qed.

  Lemma interp_env_Some_l Δ Γ vvs x τ :
    Γ !! x = Some τ → ⟦ Γ ⟧* Δ vvs ⊢ ∃ vv, ⌜vvs !! x = Some vv⌝ ∧ ⟦ τ ⟧ Δ vv.
  Proof.
    iIntros (?) "[Hlen HΓ]"; iDestruct "Hlen" as %Hlen.
    destruct (lookup_lt_is_Some_2 vvs x) as [v Hv].
    { by rewrite -Hlen; apply lookup_lt_Some with τ. }
    iExists v; iSplit. done. iApply (big_sepL_elem_of with "HΓ").
    apply elem_of_list_lookup_2 with x.
    rewrite lookup_zip_with; by simplify_option_eq.
  Qed.

  Lemma interp_env_nil Δ : ⟦ [] ⟧* Δ [].
  Proof. iSplit; simpl; auto. Qed.
  Lemma interp_env_cons Δ Γ vvs τ vv :
    ⟦ τ :: Γ ⟧* Δ (vv :: vvs) ⊣⊢ ⟦ τ ⟧ Δ vv ∗ ⟦ Γ ⟧* Δ vvs.
  Proof.
    rewrite /interp_env /= (assoc _ (⟦ _ ⟧ _ _)) -(comm _ ⌜(_ = _)⌝%I) -assoc.
    by apply sep_proper; [apply pure_proper; lia|].
  Qed.

  Lemma interp_env_ren Δ (Γ : list type) vvs τi :
    ⟦ subst (ren (+1)) <$> Γ ⟧* (τi :: Δ) vvs ⊣⊢ ⟦ Γ ⟧* Δ vvs.
  Proof.
    apply sep_proper; [apply pure_proper; by rewrite fmap_length|].
    revert Δ vvs τi; induction Γ=> Δ [|v vs] τi; csimpl; auto.
    apply sep_proper; auto. apply (interp_weaken [] [τi] Δ).
  Qed.

  Lemma interp_ref_pointsto_neq E Δ τ l w (l1 l2 l3 l4 : loc) :
    ↑logN.@(l1, l2) ⊆ E →
    l2 ≠ l4 →
    l ↦ᵢ w -∗ interp (Tref τ) Δ (LocV l1, LocV l2) -∗
      |={E ∖ ↑logN.@(l3, l4)}=> l ↦ᵢ w ∗ ⌜l ≠ l1⌝.
  Proof.
    intros Hnin Hneq.
    destruct (decide (l = l1)); subst; last auto.
    iIntros "Hl1"; simpl; iDestruct 1 as ((l5, l6)) "[% Hl2]"; simplify_eq.
    iInv (logN.@(l5, l6)) as "Hi" "Hcl"; simpl.
    iDestruct "Hi" as ((v1, v2))  "(Hl3 & Hl2' & ?)".
    iMod "Hl3".
    by iDestruct (@mapsto_valid_2 with "Hl1 Hl3") as %?.
  Qed.

  Lemma interp_ref_pointsto_neq' E Δ τ l w (l1 l2 l3 l4 : loc) :
    ↑logN.@(l1, l2) ⊆ E →
    l1 ≠ l3 →
    l ↦ₛ w -∗ interp (Tref τ) Δ (LocV l1, LocV l2) -∗
      |={E ∖ ↑logN.@(l3, l4)}=> l ↦ₛ w ∗ ⌜l ≠ l2⌝.
  Proof.
    intros Hnin Hneq.
    destruct (decide (l = l2)); subst; last auto.
    iIntros "Hl1"; simpl; iDestruct 1 as ((l5, l6)) "[% Hl2]"; simplify_eq.
    iInv (logN.@(l5, l6)) as "Hi" "Hcl"; simpl.
    iDestruct "Hi" as ((v1, v2))  "(Hl3 & Hl2' & ?)".
    iMod "Hl2'"; simpl.
    unfold heapS_mapsto.
    iDestruct (@own_valid_2 _ _ _ cfg_name with "Hl1 Hl2'") as %[_ Hvl].
    exfalso.
    specialize (Hvl l6); revert Hvl. simpl.
    rewrite /= gmap.lookup_op !lookup_singleton -Some_op. by intros [? _].
  Qed.

  Lemma interp_ref_open' Δ τ l l' :
    env_Persistent Δ → EqType τ →
    ⟦ Tref τ ⟧ Δ (LocV l, LocV l') -∗
               |={⊤, ⊤ ∖ ↑logN.@(l, l')}=>
  ∃ w w', ▷ l ↦ᵢ w ∗ ▷ l' ↦ₛ w' ∗ ▷ ⟦ τ ⟧ Δ (w, w') ∗
            ▷ (∀ z z' u u' v v',
                  l ↦ᵢ z -∗ l' ↦ₛ z' -∗ ⟦ τ ⟧ Δ (u, u') -∗ ⟦ τ ⟧ Δ (v, v') -∗
                    |={⊤ ∖ ↑logN.@(l, l')}=> l ↦ᵢ z ∗
                                              l' ↦ₛ z' ∗ ⌜v = u ↔ v' = u'⌝)
            ∗ (▷ (∃ vv : val * val, l ↦ᵢ vv.1 ∗ l' ↦ₛ vv.2 ∗ ⟦ τ ⟧ Δ vv)
          ={⊤ ∖ ↑logN.@(l, l'), ⊤}=∗ True).
  Proof.
    iIntros (HΔ Heqt); simpl.
    iDestruct 1 as ((l1, l1')) "[% H1]"; simplify_eq.
    iInv (logN.@(l1, l1')) as "Hi" "$"; simpl.
    iDestruct "Hi" as ((v1, v2))  "(Hl1 & Hl1' & Hrl)"; simpl in *.
    destruct Heqt; simpl in *.
    - iModIntro; iExists _, _; iFrame.
      iNext. iIntros (??????) "? ?". iIntros ([??] [??]); subst.
      by iModIntro; iFrame.
    - iModIntro; iExists _, _; iFrame.
      iNext. iIntros (??????) "? ?".
      iDestruct 1 as (?) "[% %]". iDestruct 1 as (?) "[% %]".
      simplify_eq. by iModIntro; iFrame.
    - iModIntro; iExists _, _; iFrame.
      iNext. iIntros (??????) "? ?".
      iDestruct 1 as (?) "[% %]". iDestruct 1 as (?) "[% %]".
      simplify_eq. by iModIntro; iFrame.
    - iModIntro; iExists _, _; iFrame; iFrame "#". iNext.
      iIntros (z z' u u' v v') "Hl1 Hl1' Huu". iDestruct 1 as ((l2, l2')) "[% #Hl2]";
        simplify_eq; simpl in *.
      iDestruct "Huu" as ((l3, l3')) "[% #Hl3]";
        simplify_eq; simpl in *.
      destruct (decide ((l1, l1') = (l2, l2'))); simplify_eq.
      + destruct (decide ((l2, l2') = (l3, l3'))); simplify_eq; first by iFrame.
        destruct (decide (l2 = l3)); destruct (decide (l2' = l3')); subst.
        * iMod (interp_ref_pointsto_neq with "Hl1 []")
               as "[Hl1 %]"; simpl; eauto.
             { by iExists (_, _); iFrame "#". }
             by iFrame.
        * iMod (interp_ref_pointsto_neq with "Hl1 []")
               as "[Hl1 %]"; simpl; eauto.
             { by iExists (_, _); iFrame "#". }
             by iFrame.
        * iMod (interp_ref_pointsto_neq' with "Hl1' []")
               as "[Hl1' %]";
               simpl; eauto.
             { by iExists (_, _); iFrame "#". }
             by iFrame.
        * iFrame; iModIntro; iPureIntro; split; by inversion 1.
      + destruct (decide ((l1, l1') = (l3, l3'))); simplify_eq.
        * destruct (decide (l2 = l3)); destruct (decide (l2' = l3')); subst.
          -- iMod (interp_ref_pointsto_neq with "Hl1 []")
              as "[Hl1 %]"; simpl; eauto.
             { by iExists (_, _); iFrame "#". }
             by iFrame.
          -- iMod (interp_ref_pointsto_neq with "Hl1 []")
               as "[Hl1 %]"; simpl; eauto.
             { iExists (_, _); iSplit; first eauto. iFrame "#". }
             by iFrame.
          -- iMod (interp_ref_pointsto_neq' with "Hl1' []")
               as "[Hl1' %]";
               simpl; eauto.
             { iExists (_, _); iSplit; first eauto. iFrame "#". }
             by iFrame.
          -- iFrame; iModIntro; iPureIntro; split; by inversion 1.
        * destruct (decide ((l2, l2') = (l3, l3'))); simplify_eq.
          -- destruct (decide (l1 = l3)); destruct (decide (l1' = l3')); subst.
             ++ iMod (interp_ref_pointsto_neq with "Hl1 []")
                 as "[Hl1 %]"; simpl; eauto.
                { by iExists (_, _); iFrame "#". }
                  by iFrame.
             ++ iMod (interp_ref_pointsto_neq with "Hl1 []")
               as "[Hl1 %]"; simpl; eauto.
                { by iExists (_, _); iFrame "#". }
                  by iFrame.
             ++ iMod (interp_ref_pointsto_neq' with "Hl1' []")
                 as "[Hl1' %]";
                  simpl; eauto.
                { by iExists (_, _); iFrame "#". }
                  by iFrame.
             ++ iFrame; iModIntro; iPureIntro; split; by inversion 1.
          -- iFrame.
             { destruct (decide (l2 = l3)); destruct (decide (l2' = l3'));
                 simplify_eq; auto.
               + iInv (logN.@(l3, l2')) as "Hib1" "Hcl1".
                 iInv (logN.@(l3, l3')) as "Hib2" "Hcl2".
                 iDestruct "Hib1" as ((v11, v12)) "(Hlx1' & Hlx2 & Hr1)".
                 iDestruct "Hib2" as ((v11', v12')) "(Hl1'' & Hl2' & Hr2)".
                 simpl.
                 iMod "Hlx1'"; iMod "Hl1''".
                   by iDestruct (@mapsto_valid_2 with "Hlx1' Hl1''") as %?.
               + iInv (logN.@(l2, l3')) as "Hib1" "Hcl1".
                 iInv (logN.@(l3, l3')) as "Hib2" "Hcl2".
                 iDestruct "Hib1" as ((v11, v12)) "(Hl1 & Hl2' & Hr1)".
                 iDestruct "Hib2" as ((v11', v12')) "(Hl1' & Hl2'' & Hr2)".
                 simpl.
                 iMod "Hl2'"; iMod "Hl2''".
                 unfold heapS_mapsto.
                 iDestruct (@own_valid_2 _ _ _ cfg_name with "Hl2' Hl2''") as %[_ Hvl].
                 exfalso.
                 specialize (Hvl l3'); revert Hvl.
                 rewrite /= gmap.lookup_op !lookup_singleton -Some_op. by intros [? _].
               + iModIntro; iPureIntro; split; intros; simplify_eq. }
  Qed.

  Definition interp_Tenv (Δ : listO D) (Ξ : list type) : iProp Σ:=
    (⌜length Δ = length Ξ⌝ ∧ ∀ x τ, ⌜Ξ !! x = Some τ⌝ →
                                    □ (∀ v, env_lookup x Δ v -∗ interp τ Δ v))%I.

  Lemma interp_Tenv_weaken Δ Ξ τ τi :
    □ (∀ v, τi v -∗ interp τ Δ v) ∧ interp_Tenv Δ Ξ
    ⊣⊢ interp_Tenv (τi :: Δ) (τ.[ren (+1)] :: (subst (ren (+1)) <$> Ξ)).
  Proof.
    iSplit.
    - iIntros "#[Hτ [Hlen HΞ]]". iDestruct "Hlen" as %Hlen.
      iSplit.
      { rewrite /= fmap_length; auto. }
      iIntros (x σ Hσ) "!#". iIntros (v) "Hv".
      destruct x; simpl in *; simplify_eq.
      + rewrite (interp_weaken [] [τi] Δ τ _) /=.
        by iApply "Hτ".
      + rewrite list_lookup_fmap in Hσ.
        destruct (Ξ !! x) as [δ|]eqn:Hxeq; last done.
        simpl in *; simplify_eq.
        rewrite (interp_weaken [] [τi] Δ δ _) /=.
        iApply "HΞ"; eauto.
    - iIntros "#[Hlen HΞ]". iDestruct "Hlen" as %Hlen.
      iSplit.
      { iAlways. iIntros (v) "Hv".
        rewrite -(interp_weaken [] [τi] Δ τ _) /=.
        by iApply ("HΞ" $! 0). }
      iSplit.
      { rewrite /= fmap_length in Hlen; auto. }
      iIntros (x σ Hσ) "!#". iIntros (v) "Hv".
      rewrite -(interp_weaken [] [τi] Δ σ _) /=.
      iApply ("HΞ" $! (S x)); last done.
      rewrite /= list_lookup_fmap Hσ //.
  Qed.

  Lemma logrel_subtyp Δ Ξ τ τ' v :
    env_Persistent Δ →
    subtype Ξ τ τ' →
    interp_Tenv Δ Ξ ⊢ □ (interp τ Δ v -∗ interp τ' Δ v).
  Proof.
    iIntros (HΔ Hsb) "#HΞ".
    iIntros "!# #Hτ".
    iInduction Hsb as [] "IH" forall (Δ HΔ v) "HΞ Hτ"; simpl; auto.
    - iDestruct "HΞ" as "[% HΞ]".
      iApply ("HΞ" $! x); eauto.
    - iApply "IH1"; eauto.
      iAlways. iApply "IH"; eauto.
    - rewrite -/interp.
      iAlways. iIntros (w) "#Hw". iIntros (j K) "Hj".
      iApply wp_wand_r; iSplitL.
      + iApply "Hτ". iApply "IH"; auto. simpl; iFrame.
      + iIntros (?). iDestruct 1 as (u) "[Hu #Hτu]"; iExists _; iFrame.
        iApply "IH1"; eauto.
    - rewrite -/interp.
      iAlways. iIntros (τi Hτi) "#Hτi". iIntros (j K) "Hj".
      iApply wp_wand_r; iSplitL; first by iApply "Hτ"; eauto.
      iIntros (?). iDestruct 1 as (u) "[Hu #Hτu]"; iExists _; iFrame.
      iApply "IH"; eauto.
      + by iPureIntro; apply env_persistent_cons.
      + iAlways. rewrite -interp_Tenv_weaken; auto.
    - iLöb as "ILH" forall (v) "Hτ".
      rewrite (fixpoint_unfold (interp_rec1 ⟦ σ ⟧ Δ) v).
      rewrite (fixpoint_unfold (interp_rec1 ⟦ τ ⟧ Δ) v).
      simpl.
      iAlways.
      iDestruct "Hτ" as ([w1 w2] ?) "Hτ".
      iExists _; iSplit; first done.
      iNext.
      iSpecialize ("IH" $! (fixpoint (interp_rec1 ⟦ σ ⟧ Δ) ::
                            fixpoint (interp_rec1 ⟦ τ ⟧ Δ) :: Δ) with "[]").
      { iPureIntro.
        constructor; last constructor; last done.
        - intros; by apply (interp_persistent (TRec σ)).
        - intros; by apply (interp_persistent (TRec τ)). }
      iSpecialize ("IH" $! (w1, w2) with "[]").
      { iAlways.
        iDestruct "HΞ" as "[HΞ1 HΞ2]".
        iSplit.
        { rewrite /= fmap_length. by iDestruct "HΞ1" as %->. }
        iIntros (x ρ Hx).
        destruct x as [|[|x]]; simpl in *; simplify_eq; simpl.
        - change (fixpoint (interp_rec1 ⟦ σ ⟧ Δ)) with (⟦ TRec σ ⟧ Δ).
          iAlways. by iIntros (u) "#?"; iApply "ILH".
        - change (fixpoint (interp_rec1 ⟦ τ ⟧ Δ)) with (⟦ TRec τ ⟧ Δ).
          change (fixpoint (interp_rec1 ⟦ σ ⟧ Δ)) with (⟦ TRec σ ⟧ Δ).
          iAlways. by iIntros (u) "#?".
        - iAlways.
          rewrite list_lookup_fmap in Hx.
          iIntros (u) "Hu".
          destruct (Δ !! x) as [δ|] eqn:HΔx; rewrite HΔx; last done.
          destruct (Ξ !! x) as [δ'|] eqn:HΞx; last done.
          iSpecialize ("HΞ2" $! x δ' with "[]"); first done.
          rewrite HΔx; simpl.
          iSpecialize ("HΞ2" $! u with "Hu").
          simpl in *; simplify_eq.
          change (δ'.[ren (+2)]) with (δ'.[upn 0 (ren (+2))]).
          by rewrite (interp_weaken [] [_; _] _ _ _). }
      rewrite (interp_weaken [] [_] (_ :: _) _ _).
      rewrite (interp_weaken [_] [_] _ _ _).
      by iApply "IH".
  Qed.

End logrel.

Typeclasses Opaque interp_env.
Notation "⟦ τ ⟧" := (interp τ).
Notation "⟦ τ ⟧ₑ" := (interp_expr (interp τ)).
Notation "⟦ Γ ⟧*" := (interp_env Γ).


From Coq Require Import
     ssreflect
     String
.

From ExtensibleCompiler.Hacks Require Import
     TypeClassResolutionForHave
.

From ExtensibleCompiler.Semantics Require Import
     Dynamic.Eval.If2
     Static.TypeEquality
     Static.TypeEqualityCorrectness
     Static.TypeOf
     Static.TypeOf.If2
     Static.WellTyped.Bool
     Static.WellTyped.If2
.

From ExtensibleCompiler.Syntax Require Import
     Terms.Bool
     Terms.If2
     Terms.Stuck
     Types.BoolType
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Eval
     Functor
     IndexedAlgebra
     IndexedFunctor
     IndexedProofAlgebra
     IndexedSubFunctor
     ProgramAlgebra
     ProofAlgebra
     SubFunctor
     Types
     TypeSoundness
     UniversalProperty
.

Local Open Scope SubFunctor.

Section If2.

  Context

    {V}
    `{Functor V}
    `{! V supports Bool}
    `{! V supports Stuck}

    {T}
    `{Functor T}
    `{! T supports BoolType}

    {E}
    `{Functor E}
    `{! E supports If2}

    {typeEqualityForT : forall R, ProgramAlgebra ForTypeEquality T R (TypeEqualityResult T)}
  .

  Lemma Soundness__if2

        (WTV : (TypedExpr T V)-indexedPropFunctor)
        `(IndexedFunctor (TypedExpr T V) WTV)
        `((WellTypedValue__Bool <= WTV)%IndexedSubFunctor)

        `{! forall {R}, ProgramAlgebra    ForEval E R (EvalResult V)}

        (Eval__R : Set)
        {F} `{Functor F} `{F supports If2}
        recEval

        (TypeOf__R : Set)
        recTypeOf

        `{PA__TEC :
            ! ProofAlgebra ForTypeEqualityCorrectness T
              (sig (UniversalPropertyP typeEqualityCorrectnessStatement))}
        `{! WellFormedProofAlgebra PA__TEC }

        `{! IndexedProofAlgebra ForWellTypedValueProjection__Bool WTV
            (WellTypedValueProjectionStatement__Bool WTV)}
        `{! IndexedProofAlgebra ForWellTypedProj1Type WTV
            (PropertyStatement__WellTypedProj1Type WTV)
         }

    : forall Gamma (c t e : TypeOf__R) (c' t' e' : Eval__R),

      (forall tau,
          recTypeOf c = Some tau ->
          WellTyped WTV tau (recEval c' Gamma)
      ) ->

      (forall tau,
          recTypeOf t = Some tau ->
          WellTyped WTV tau (recEval t' Gamma)
      ) ->

      (forall tau,
          recTypeOf e = Some tau ->
          WellTyped WTV tau (recEval e' Gamma)
      ) ->

      forall tau,
        typeOf__If2 TypeOf__R recTypeOf (MkIf2 c t e) = Some tau ->
        WellTyped WTV tau
                  (eval__If2 Eval__R recEval (MkIf2 c' t' e') Gamma).
  Proof.
    rewrite /=.
    move => Gamma c t e c' t' e'.
    case TO__c : (recTypeOf c) => [ tau__c | ] // IH__c.
    move : IH__c (IH__c _ eq_refl) => _ WT__c.
    case BT : (isBoolType (proj1_sig tau__c)) => //.
    case TO__t : (recTypeOf t) => [ [ tau__t UP'__tau__t ] | ] // IH__t.
    move : IH__t (IH__t _ eq_refl) => _ WT__t.
    case TO__e : (recTypeOf e) => [ tau__e | ] // IH__e.
    move : IH__e (IH__e _ eq_refl) => _ WT__e.
    move => tau.
    case TE : (typeEquality tau__t tau__e) => //.
    move => [] <-.
    move : BT.
    rewrite / isBoolType.
    case p__c : (projectUP' (proj1_sig tau__c)) => [ [] | ] // _.
    {
      have := (project_successUP' _ _ (proj2_sig tau__c) p__c) => {}p__c.
      have := !! wellTypedValueProjection__Bool _ _ WT__c p__c.
      elim / @WellTypedValueInversionClear__Bool => _ _ b [] -> -> -> _.
      rewrite / isBoolean / projectUP' / if2F' / if2 /=.
      rewrite unwrapUP'_wrapF.
      rewrite wellFormedSubFunctor.
      rewrite wellFormedSubFunctor.
      rewrite project_inject /=.
      move : b => [].
      {
        apply WT__t.
      }
      {
        have := !! typeEqualityCorrectness (exist _ _ _) _ TE => TEC.
        have := !! wellTypedProj1Type _ _ WT__e _ UP'__tau__t TEC => //.
      }
    }
  Defined.

  Global Instance Soundness__If2

         (WTV : (TypedExpr T V)-indexedPropFunctor)
         `(IndexedFunctor (TypedExpr T V) WTV)
         `((WellTypedValue__Bool  <= WTV)%IndexedSubFunctor)

         `{Eval__E : ! forall R, ProgramAlgebra ForEval E R (EvalResult V)}
         `{! forall R, WellFormedCompoundProgramAlgebra (Eval__E R) (Eval__If2 R)}
         (recEval : WellFormedValue E -> EvalResult   V)

         `{TypeOf__E : ! forall R, ProgramAlgebra ForTypeOf E R (TypeOfResult T)}
         `{! forall R, WellFormedCompoundProgramAlgebra (TypeOf__E R) (TypeOf__If2 R)}
         (recTypeOf : WellFormedValue E -> TypeOfResult T)

        `{PA__TEC :
            ! ProofAlgebra ForTypeEqualityCorrectness T
              (sig (UniversalPropertyP typeEqualityCorrectnessStatement))}
        `{! WellFormedProofAlgebra PA__TEC}

        `{! IndexedProofAlgebra ForWellTypedValueProjection__Bool WTV
            (WellTypedValueProjectionStatement__Bool WTV)}

        `{! IndexedProofAlgebra ForWellTypedProj1Type WTV
            (PropertyStatement__WellTypedProj1Type WTV)
         }

    : ProofAlgebra
        ForSoundness If2
        (sig (UniversalPropertyP2
                (AbstractSoundnessStatement' WTV recEval recTypeOf))).
  Proof.
    constructor.
    apply Induction2__If2.
    rewrite / AbstractSoundnessStatement' / AbstractSoundnessStatement.
    rewrite / UniversalPropertyP2 /=.
    move => [c1 c2] [t1 t2] [e1 e2] /=.
    move => [[UP'__c1 UP'__c2] IH__c] [[UP'__t1 UP'__t2] IH__t] [[UP'__e1 UP'__e2] IH__e].
    constructor.
    {
      apply conj; exact (proj2_sig (if2 _ _ _)).
    }
    {
      move => Gamma.
      rewrite / if2F' / if2F / if2 / inject /=.
      rewrite !unwrapUP'_wrapF /=.
      rewrite !fmapFusion /=.
      rewrite / compose /=.
      rewrite !wellFormedSubFunctor => //=.
      rewrite / programAlgebra'.
      rewrite ! wellFormedCompoundProgramAlgebra.
      move => IH tau.
      eapply Soundness__if2 => //.

      (* condition *)
      {
        move => ?.
        apply (IH Gamma (exist _ _ UP'__c1, _)) => /=.
        {
          move => A B.
          apply (IH__c Gamma IH).
          now rewrite <- (wrapUP'_unwrapUP' c2).
        }
      }

      (* then branch *)
      {
        move => ?.
        apply (IH Gamma (exist _ _ UP'__t1, _)) => /=.
        {
          move => A B.
          apply (IH__t Gamma IH).
          now rewrite <- (wrapUP'_unwrapUP' t2).
        }
      }

      (* else branch *)
      {
        move => ?.
        apply (IH Gamma (exist _ _ UP'__e1, _)) => /=.
        {
          move => A B.
          apply (IH__e Gamma IH).
          now rewrite <- (wrapUP'_unwrapUP' e2).
        }
      }

    }
  Defined.

End If2.


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 E Eprime S U1 A AX B BX C CX BXMAX CXMAX AB AC IAC T A1 A2 BXprime CXprime ABXprimeprime ACXprimeprime : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A1 A2 /\ (wd_ C CXprime /\ (wd_ B BXprime /\ (wd_ A BXprime /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ S U1 /\ (col_ O E AX /\ (col_ O E BX /\ (col_ O E CX /\ (col_ O E BXMAX /\ (col_ O E CXMAX /\ (col_ O E T /\ (col_ O E AB /\ (col_ O E AC /\ (col_ O E IAC /\ (col_ A A1 A2 /\ (col_ O E ABXprimeprime /\ (col_ O E ACXprimeprime /\ (col_ A1 A2 BXprime /\ (col_ S U1 BXprime /\ (col_ A1 A2 C /\ (col_ S U1 CXprime /\ col_ A B C))))))))))))))))))))))))))) -> col_ A B BXprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Undecidability Result(s):
    Provability in Hilbert-style calculi (HSC_PRV)
    Recognizing axiomatizations of Hilbert-style calculi (HSC_AX)
*)

Require Import Undecidability.Synthetic.Undecidability.

Require Import Undecidability.HilbertCalculi.HSC.

Require Undecidability.HilbertCalculi.Reductions.MPCPb_to_HSC_PRV.
Require Undecidability.HilbertCalculi.Reductions.MPCPb_to_HSC_AX.

Require Import Undecidability.PCP.PCP_undec.

(* Hilbert-style Axiomatization of the Post Correspondenc Problem *)
Definition ΓPCP := MPCPb_to_HSC_PRV.Argument.ΓPCP.

(* Undecidability of Provability in Hilbert-style Calculi with the Fixed Environment ΓPCP *)
Theorem HSC_PRV_undec : undecidable (HSC_PRV ΓPCP).
Proof.
  apply (undecidability_from_reducibility MPCPb_undec).
  exact MPCPb_to_HSC_PRV.reduction.
Qed.

Check HSC_PRV_undec.

(* Undecidability of Recognizing Axiomatizations of Hilbert-style Calculi *)
Theorem HSC_AX_undec : undecidable HSC_AX.
Proof.
  apply (undecidability_from_reducibility MPCPb_undec).
  exact MPCPb_to_HSC_AX.reduction.
Qed.

Check HSC_AX_undec.