From Coq Require Import ZArith.
From Coq Require Import List. Import ListNotations.
From ConCert.Utils Require Import Extras.
From ConCert.Utils Require Import RecordUpdate.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import ContractCommon.
From ConCert.Execution Require Import Monad.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Serializable.
From ConCert.Examples.FA2 Require Import FA2LegacyInterface.

Section FA2Token.
  Context {BaseTypes : ChainBase}.
  Set Primitive Projections.
  Set Nonrecursive Elimination Schemes.
  Open Scope N_scope.

  (* Any contract that wants to receive callback messages from the FA2 contract
    should have this type as its Msg type. The contract may have other endpoints,
    as composed in the 'other_msg' constructor *)
  Inductive FA2ReceiverMsg {Msg' : Type} :=
  | receive_balance_of_param : list balance_of_response -> FA2ReceiverMsg
  | receive_total_supply_param : list total_supply_response -> FA2ReceiverMsg
  | receive_metadata_callback : list token_metadata -> FA2ReceiverMsg
  | receive_is_operator : is_operator_response -> FA2ReceiverMsg
  | receive_permissions_descriptor : permissions_descriptor -> FA2ReceiverMsg
  | other_msg : Msg' -> FA2ReceiverMsg.

  (* Transfer hook contracts of the FA2 Contract should use this type as their Msg type *)
  Inductive FA2TransferHook {Msg : Type} :=
  | transfer_hook : transfer_descriptor_param -> FA2TransferHook
  | hook_other_msg : Msg -> FA2TransferHook.

  (* The FA2 Endpoints. *)
  Inductive Msg :=
  | msg_transfer : list transfer -> Msg
  | msg_set_transfer_hook : set_hook_param -> Msg
  | msg_receive_hook_transfer : transfer_descriptor_param -> Msg
  | msg_balance_of : balance_of_param -> Msg
  | msg_total_supply : total_supply_param -> Msg
  | msg_token_metadata : token_metadata_param -> Msg
  | msg_permissions_descriptor : callback permissions_descriptor -> Msg
  | msg_update_operators : list update_operator -> Msg
  | msg_is_operator : is_operator_param -> Msg
  | msg_create_tokens : token_id -> Msg.

  Record TokenLedger :=
    build_token_ledger {
      fungible : bool;
      balances : FMap Address N
    }.

  Record State :=
    build_state {
      fa2_owner          : Address;
      assets             : FMap token_id TokenLedger;
      operators          : FMap Address (FMap Address operator_tokens);
      permission_policy  : permissions_descriptor;
      tokens             : FMap token_id token_metadata;
      transfer_hook_addr : option Address;
    }.

  Record Setup :=
    build_setup {
      setup_total_supply        : list (token_id * N);
      setup_tokens              : FMap token_id token_metadata;
      initial_permission_policy : permissions_descriptor;
      transfer_hook_addr_       : option Address;
    }.

  Definition Error : Type := nat.
  Definition default_error : Error := 1%nat.

  MetaCoq Run (make_setters TokenLedger).
  MetaCoq Run (make_setters State).
  MetaCoq Run (make_setters Setup).

  Section Serialization.

    Global Instance setup_serializable : Serializable Setup :=
      Derive Serializable Setup_rect <build_setup>.

    Global Instance FA2ReceiverMsg_serializable {Msg : Type}
                                                `{Serializable Msg}
                                                : Serializable (@FA2ReceiverMsg Msg) :=
      Derive Serializable (@FA2ReceiverMsg_rect Msg) <
        (@receive_balance_of_param Msg),
        (@receive_total_supply_param Msg),
        (@receive_metadata_callback Msg),
        (@receive_is_operator Msg),
        (@receive_permissions_descriptor Msg),
        (@other_msg Msg)>.

    Global Instance FA2TransferHook_serializable {Msg : Type}
                                                `{Serializable Msg}
                                                : Serializable (@FA2TransferHook Msg) :=
      Derive Serializable (@FA2TransferHook_rect Msg) <
        (@transfer_hook Msg),
        (@hook_other_msg Msg)>.

    Global Instance callback_permissions_descriptor_serializable : Serializable (callback permissions_descriptor) :=
      callback_serializable.

    Global Instance msg_serializable : Serializable Msg :=
      Derive Serializable Msg_rect <
        msg_transfer,
        msg_set_transfer_hook,
        msg_receive_hook_transfer,
        msg_balance_of,
        msg_total_supply,
        msg_token_metadata,
        msg_permissions_descriptor,
        msg_update_operators,
        msg_is_operator,
        msg_create_tokens>.

    Global Instance TokenLedger_serializable : Serializable TokenLedger :=
      Derive Serializable TokenLedger_rect <build_token_ledger>.

    Global Instance state_serializable : Serializable State :=
      Derive Serializable State_rect <build_state>.

  End Serialization.

  Definition address_balance (token_id : token_id)
                             (addr : Address)
                             (state : State)
                             : N :=
    match FMap.find token_id state.(assets) with
    | Some ledger => with_default 0%N (FMap.find addr ledger.(balances))
    | None => 0%N
    end.

  Definition address_has_sufficient_asset_balance (token_id : token_id)
                                                  (owner : Address)
                                                  (transaction_amount : N)
                                                  (state : State)
                                                  : result unit Error :=
    if transaction_amount <=? address_balance token_id owner state
    then Ok tt
    else Err default_error.

  Definition policy_disallows_operator_transfer (policy : permissions_descriptor) : bool :=
    match policy.(descr_operator) with
    | operator_transfer_permitted => false
    | operator_transfer_denied => true
    end.

  Definition policy_disallows_self_transfer (policy : permissions_descriptor) : bool :=
    match policy.(descr_self) with
    | self_transfer_permitted => false
    | self_transfer_denied => true
    end.

  Definition get_owner_operator_tokens (owner operator : Address)
                                       (state : State)
                                       : option operator_tokens :=
    do operator_tokens <- FMap.find owner state.(operators) ;
    FMap.find operator operator_tokens.

  (* Executes a single transfer by returning a new state, if successful. *)
  Definition try_single_transfer (caller : Address)
                                 (params : transfer)
                                 (state : State)
                                 : result State Error :=
    do _ <- throwIf (negb (1 =? N.of_nat (length params.(txs)))) default_error;
    do transfer_dst <- result_of_option (hd_error (params.(txs))) default_error;
    do ledger <- result_of_option (FMap.find transfer_dst.(dst_token_id) state.(assets)) default_error;
    let current_owner_balance := address_balance transfer_dst.(dst_token_id) params.(from_) state in
    let new_balances := FMap.add params.(from_) (current_owner_balance - transfer_dst.(amount)) ledger.(balances) in
    let new_balances := FMap.partial_alter (fun balance =>
      Some ((with_default 0 balance) + transfer_dst.(amount))) transfer_dst.(to_) new_balances in
    let new_ledger := ledger<|balances := new_balances|> in
      Ok (state<|assets ::= FMap.add transfer_dst.(dst_token_id) new_ledger|>).

  Definition transfer_check_permissions (caller : Address)
                                        (params : transfer)
                                        (policy : permissions_descriptor)
                                        (state : State)
                                        : result unit Error :=
    do _ <- throwIf (negb (1 =? N.of_nat (length params.(txs)))) default_error;
    do transfer_dst <- result_of_option (hd_error (params.(txs))) default_error;
    (* check for sufficient permissions *)
    do _ <- address_has_sufficient_asset_balance transfer_dst.(dst_token_id) params.(from_) transfer_dst.(amount) state ;
    (* only allow transfers of known token_ids *)
    do _ <- result_of_option (FMap.find transfer_dst.(dst_token_id) state.(tokens)) default_error;
    (* if caller is owner of transfer, then check policy if self_transfer is allowed *)
    if (address_eqb caller params.(from_))
    then
      throwIf (policy_disallows_self_transfer policy) default_error
    else
      (* check if policy allows operator transfer *)
      do _ <- throwIf (policy_disallows_operator_transfer policy) default_error;
      do operators_map <- result_of_option (FMap.find params.(from_) state.(operators)) default_error;
      do op_tokens <- result_of_option (FMap.find caller operators_map) default_error;
      (* check if operator has permission to transfer the given token_id type *)
      match op_tokens with
      | all_tokens => Ok tt
      | some_tokens token_ids => if (existsb (fun id => id =? transfer_dst.(dst_token_id)) token_ids)
                                then Ok tt
                                else Err default_error
      end.

  (* Executes all transfers in a batch operation and returns a new state if *all*
    transfers were successful. *)
  Definition try_transfer (caller : Address)
                          (transfers : list transfer)
                          (state : State)
                          : result State Error :=
    let check_transfer_iterator state_opt params :=
      do state <- state_opt ;
      do _ <- transfer_check_permissions caller params state.(permission_policy) state;
      try_single_transfer caller params state in
    (* returns the new state if all transfers *can* succeed, otherwise returns None *)
    fold_left check_transfer_iterator transfers (Ok state).

  (* Forwards the transfer to the hook to approve/reject *)
  Definition call_transfer_hook (caller : Address)
                                (caddr : Address)
                                (transfer_hook_addr : Address)
                                (transfers : list transfer)
                                (state : State)
                                : ActionBody :=
    let mk_transfer_dst_descr tr_dst := {|
      transfer_dst_descr_to_ := Some tr_dst.(to_);
      transfer_dst_descr_token_id := tr_dst.(dst_token_id);
      transfer_dst_descr_amount := tr_dst.(amount)
      |} in
    let mk_transfer_descr tr := {|
      transfer_descr_from_ := Some (tr.(from_));
      transfer_descr_txs := map mk_transfer_dst_descr tr.(txs)
      |} in
    let transfer_decr_param := {|
      transfer_descr_fa2 := caddr;
      transfer_descr_batch := map mk_transfer_descr transfers;
      transfer_descr_operator := caller;
      |} in
    act_call transfer_hook_addr 0%Z (serialize (transfer_hook transfer_decr_param)).

  Definition group_transfer_descriptors (params : list transfer_descriptor)
                                        : list (list transfer_descriptor) :=
    let trx_map := fold_right (fun trx trx_map =>
    match FMap.find trx.(transfer_descr_from_) trx_map with
    | Some trxs => FMap.add trx.(transfer_descr_from_) (trx :: trxs) trx_map
    | None => FMap.add trx.(transfer_descr_from_) [trx] trx_map
    end
    ) FMap.empty params in
    FMap.values trx_map.

  (* Handles incoming transfers:
    - if the contract has a transfer_hook, then it uses the hook
    - otherwise it checks & performs the transfers now *)
  Definition handle_transfer (caller : Address)
                             (caddr : Address)
                             (transfers : list transfer)
                             (state : State)
                             : result (State * list ActionBody) Error :=
    match state.(transfer_hook_addr) with
    (* send call transfer hook (approved transfers will be received in the msg_receive_hook_transfer endpoint) *)
    | Some transfer_hook_addr =>
      let call_hook_act := call_transfer_hook caller caddr transfer_hook_addr transfers state in
      Ok (state, [call_hook_act])
    (* if no hook is attached, send transfer message to self, and notify senders of transfer *)
    | None =>
    let mk_transfer_dst_descr tr_dst := {|
      transfer_dst_descr_to_ := Some tr_dst.(to_);
      transfer_dst_descr_token_id := tr_dst.(dst_token_id);
      transfer_dst_descr_amount := tr_dst.(amount)
      |} in
    let mk_transfer_descr tr := {|
      transfer_descr_from_ := Some (tr.(from_));
      transfer_descr_txs := map mk_transfer_dst_descr tr.(txs)
      |} in
      let mk_transfer_decr_param batch := {|
        transfer_descr_fa2 := caddr;
        transfer_descr_batch := batch;
        transfer_descr_operator := caller;
      |} in
      let transfer_decr_param := mk_transfer_decr_param (map mk_transfer_descr transfers) in
      let is_from_contract descriptors := existsb (fun descr =>
        match descr.(transfer_descr_from_) with
        | Some addr => address_is_contract addr
        | None => false
        end) descriptors in
      let trx_descriptors_grouped := (group_transfer_descriptors (map mk_transfer_descr transfers)) in
      let self_transfer_act := act_call caddr 0%Z (serialize (msg_receive_hook_transfer transfer_decr_param)) in

      let mk_sender_hook_act trx :=
        match trx.(sender_callback_addr) with
        | Some callback_addr =>
          let descr := mk_transfer_decr_param [mk_transfer_descr trx] in
          Some (act_call callback_addr 0%Z (@serialize fa2_token_sender _ (tokens_sent descr)))
        | None => None
        end in
      let sender_hook_acts := fold_right (fun act_opt acc =>
        match act_opt with
        | Some act => act :: acc
        | None => acc
        end
      ) [] (map mk_sender_hook_act transfers) in
      (* If no sender callbacks need to be made, just perform transfers now *)
      if Nat.eqb (length sender_hook_acts) 0%nat then
        (try_transfer caller transfers state) >>= (fun new_state => Ok (new_state, []))
      else
        (* Notice that sender hooks are invoked before the transfer *)
        Ok (state, sender_hook_acts ++ [self_transfer_act])
    end.

  Open Scope bool_scope.
  Definition mk_transfer_destination_from_descr (dst_descr: transfer_destination_descriptor)
                                                : option transfer_destination :=
    do to <- dst_descr.(transfer_dst_descr_to_) ;
    Some {|
      to_ := to;
      dst_token_id := dst_descr.(transfer_dst_descr_token_id);
      amount := dst_descr.(transfer_dst_descr_amount)
    |}.

  Definition mk_transfer_from_descr (descr: transfer_descriptor) : option transfer :=
    do from <- descr.(transfer_descr_from_) ;
    let iter := (fun dst_descr acc_opt =>
      do acc <- acc_opt;
      do tx_dst <- mk_transfer_destination_from_descr dst_descr;
      Some (tx_dst :: acc)) in
    do txs_list <- fold_right iter (Some []) descr.(transfer_descr_txs);
    Some {|
      from_ := from;
      txs := txs_list;
      sender_callback_addr := None
    |}.

  Definition handle_transfer_hook_receive (caller : Address)
                                          (param : transfer_descriptor_param)
                                          (self_addr : Address)
                                          (state : State)
                                          : result State Error :=
    (* check if caller is current hook or self - only hook or self is allowed to call this endpoint *)
    do _ <- if (match state.(transfer_hook_addr) with
            | Some hook_addr => ((address_eqb caller hook_addr) || (address_eqb caller self_addr))
            | None => (address_eqb caller self_addr)
            end)
            then Ok tt
            else Err default_error;
    let iter := (fun descr acc_opt =>
      do acc <- acc_opt;
      do trans <- result_of_option (mk_transfer_from_descr descr) default_error;
      Ok (trans :: acc)) in
    do transfers <- fold_right iter (Ok []) param.(transfer_descr_batch) ;
    try_transfer param.(transfer_descr_operator) transfers state.
  Close Scope bool_scope.

  (* create a 'balance_of' action to send to the callback address *)
  Definition get_balance_of_callback (param : balance_of_param)
                                     (state : State)
                                     : ActionBody :=
    let bal_req_iterator (bal_req : balance_of_request) :=
      let owner_bal := address_balance bal_req.(bal_req_token_id) bal_req.(owner) state in
      Build_balance_of_response bal_req owner_bal in
    let responses := map bal_req_iterator param.(bal_requests) in
    let response_msg := serialize (receive_balance_of_param responses) in
    act_call param.(bal_callback) 0%Z response_msg.

  (* create a 'total_supply' action to send to the callback address *)
  Definition get_total_supply_callback (param : total_supply_param)
                                       (state : State)
                                       : ActionBody :=
    let token_id_balance (token_id : token_id) : N :=
      match FMap.find token_id state.(assets) with
      | Some ledger => fold_left N.add (FMap.values ledger.(balances)) 0%N
      | None => 0%N
      end in
    let mk_response (token_id : token_id) : total_supply_response :=
      Build_total_supply_response token_id (token_id_balance token_id) in
    let responses := map mk_response param.(supply_param_token_ids) in
    let response_msg := serialize (receive_total_supply_param responses) in
    act_call param.(supply_param_callback) 0%Z response_msg.

  (* Updates operators if policy allows it, and if the caller is the owner. *)
  Definition update_operators (caller : Address)
                              (updates : list update_operator)
                              (state : State)
                              : result State Error :=
    (* If policy doesn't allow operator transfer, then this operation fails *)
    do _ <- throwIf (policy_disallows_operator_transfer state.(permission_policy)) default_error;
    let exec_add params (state_opt : result State Error) : result State Error :=
      do state_ <- state_opt ;
      (* only the owner of the token is allowed to update their operators *)
      if (address_neqb caller params.(op_param_owner))
      then Err default_error
      else
        let operator_tokens : FMap Address operator_tokens :=
          with_default FMap.empty (FMap.find caller state_.(operators)) in
        (* Add new operator *)
        let operator_tokens :=
          FMap.add params.(op_param_operator) params.(op_param_tokens) operator_tokens in
        Ok (state_<| operators ::= FMap.add caller operator_tokens |>) in
    let exec_update state_ op := match op with
                                | add_operator params => exec_add params state_
                                | remove_operator params => exec_add params state_
                                end in
    (fold_left exec_update updates (Ok state)).

  Definition operator_tokens_eqb (a b : operator_tokens) : bool :=
    match (a, b) with
    | (all_tokens, all_tokens) => true
    | (some_tokens a', some_tokens b') =>
      let fix my_list_eqb l1 l2 :=
        match (l1, l2) with
        | (x :: l1, y :: l2) => if x =? y
                                then my_list_eqb l1 l2
                                else false
        | ([], []) => true
        | _ => false
        end in my_list_eqb a' b'
    | _ => false
    end.

  Definition get_is_operator_response_callback (params : is_operator_param)
                                               (state : State)
                                               : result (State * list ActionBody) Error :=
    (* if policy doesn't allow operator transfers, then this operation will fail *)
    do _ <- throwIf (policy_disallows_operator_transfer state.(permission_policy)) default_error;
    let operator_params := params.(is_operator_operator) in
    let operator_tokens_opt := get_owner_operator_tokens operator_params.(op_param_owner)
                                                         operator_params.(op_param_operator) in
    let is_operator_result := match operator_tokens_opt state with
                              (* check if operator_tokens from the params and from the state are equal *)
                              | Some op_tokens => operator_tokens_eqb op_tokens operator_params.(op_param_tokens)
                              | None => false
                              end in
    let response : is_operator_response := {| operator := operator_params; is_operator := is_operator_result |} in
    let act := act_call params.(is_operator_callback) 0%Z (serialize (receive_is_operator response)) in
      Ok (state, [act]).

  Definition get_permissions_descriptor_callback (caller : Address)
                                                 (state : State)
                                                 : ActionBody :=
    let response := serialize (receive_permissions_descriptor state.(permission_policy)) in
    act_call caller 0%Z response.

  Definition try_set_transfer_hook (caller : Address)
                                   (params : set_hook_param)
                                   (state : State)
                                   : result State Error :=
    (* only owner can set transfer hook *)
    do _ <- throwIf (address_neqb caller state.(fa2_owner)) default_error;
    Ok (state<| transfer_hook_addr := Some params.(hook_addr)|>
              <| permission_policy := params.(hook_permissions_descriptor) |>).

  Definition get_token_metadata_callback (param : token_metadata_param)
                                         (state : State)
                                         : ActionBody :=
    let token_ids := param.(metadata_token_ids) in
    let state_tokens := state.(tokens) in
    let metadata_list : list token_metadata := fold_right (fun id acc =>
        match FMap.find id state_tokens with
        | Some metadata => metadata :: acc
        | None => acc
        end
      ) [] token_ids in
    let response := serialize (receive_metadata_callback metadata_list) in
    act_call param.(metadata_callback) 0%Z response.

  (* creates some tokens with a fixed exchange ratio of 1:100 *)
  Definition try_create_tokens (caller : Address)
                               (amount : Amount)
                               (tokenid : token_id)
                               (state : State)
                               : result State Error :=
    let exchange_rate := 100%Z in
    do ledger <- result_of_option (FMap.find tokenid state.(assets)) default_error;
    (* only allow amounts > 0 *)
    do _ <- throwIf (Z.leb amount 0%Z) default_error;
    let amount := Z.to_N (amount * exchange_rate) in
    let caller_bal := with_default 0 (FMap.find caller ledger.(balances)) in
    let new_balances := FMap.add caller (caller_bal + amount) ledger.(balances) in
    let new_ledger := ledger<| balances := new_balances |> in
    Ok (state<| assets ::= FMap.add tokenid new_ledger |>).

  Open Scope Z_scope.
  Definition receive (chain : Chain)
                     (ctx : ContractCallContext)
                     (state : State)
                     (maybe_msg : option Msg)
                     : result (State * list ActionBody) Error :=
    let sender := ctx.(ctx_from) in
    let caddr := ctx.(ctx_contract_address) in
    let without_statechange acts := Ok (state, acts) in
    (* Only 'create_token' messages are allowed to carry money *)
    if ctx.(ctx_amount) >? 0
    then match maybe_msg with
    | Some (msg_create_tokens tokenid) =>
        without_actions (try_create_tokens sender ctx.(ctx_amount) tokenid state)
    | _ => Err default_error
    end
    else match maybe_msg with
    | Some (msg_transfer transfers) =>
        handle_transfer sender caddr transfers state
    | Some (msg_receive_hook_transfer param) =>
        without_actions (handle_transfer_hook_receive sender param caddr state)
    | Some (msg_is_operator params) =>
        get_is_operator_response_callback params state
    | Some (msg_balance_of params) =>
        without_statechange [get_balance_of_callback params state]
    | Some (msg_total_supply params) =>
        without_statechange [get_total_supply_callback params state]
    | Some (msg_permissions_descriptor _) =>
        without_statechange [get_permissions_descriptor_callback sender state]
    | Some (msg_token_metadata param) =>
        without_statechange [get_token_metadata_callback param state]
    | Some (msg_update_operators updates) =>
        without_actions (update_operators sender updates state)
    | Some (msg_set_transfer_hook params) =>
        without_actions (try_set_transfer_hook sender params state)
    | _ => Err default_error
    end.

  Definition map_values_FMap {A B C: Type}
                            `{countable.Countable A}
                            `{base.EqDecision A}
                             (f : B -> C)
                             (m : FMap A B)
                             : FMap A C :=
    let l := FMap.elements m in
    let mapped_l := List.map (fun '(a, b) => (a, f b)) l in
    FMap.of_list mapped_l.

  Definition init (chain : Chain)
                  (ctx : ContractCallContext)
                  (setup : Setup)
                  : result State Error :=
    (* setup ledgers with empty balance for each initial token id *)
    let assets' := map_values_FMap (fun _ =>
      build_token_ledger false FMap.empty
    ) setup.(setup_tokens) in
    Ok {| permission_policy := setup.(initial_permission_policy);
            fa2_owner := ctx.(ctx_from);
            transfer_hook_addr := setup.(transfer_hook_addr_);
            assets := assets';
            operators := FMap.empty;
            tokens := setup.(setup_tokens)
      |}.

  Definition contract : Contract Setup Msg State Error :=
    build_contract init receive.

End FA2Token.


Require Export VST.concurrency.paco.src.paconotation VST.concurrency.paco.src.pacotac VST.concurrency.paco.src.pacodef VST.concurrency.paco.src.pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 6
*)

(** 1 Mutual Coinduction *)

Section Arg6_1.

Definition monotone6 T0 T1 T2 T3 T4 T5 (gf: rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5) :=
  forall x0 x1 x2 x3 x4 x5 r r' (IN: gf r x0 x1 x2 x3 x4 x5) (LE: r <6= r'), gf r' x0 x1 x2 x3 x4 x5.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable gf : rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5.
Arguments gf : clear implicits.

Theorem paco6_acc: forall
  l r (OBG: forall rr (INC: r <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6 gf rr),
  l <6= paco6 gf r.
Proof.
  intros; assert (SIM: paco6 gf (r \6/ l) x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_mon: monotone6 (paco6 gf).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_mult_strong: forall r,
  paco6 gf (upaco6 gf r) <6= paco6 gf r.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Corollary paco6_mult: forall r,
  paco6 gf (paco6 gf r) <6= paco6 gf r.
Proof. intros; eapply paco6_mult_strong, paco6_mon; eauto. Qed.

Theorem paco6_fold: forall r,
  gf (upaco6 gf r) <6= paco6 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco6_unfold: forall (MON: monotone6 gf) r,
  paco6 gf r <6= gf (upaco6 gf r).
Proof. unfold monotone6; intros; destruct PR; eauto. Qed.

End Arg6_1.

Hint Unfold monotone6.
Hint Resolve paco6_fold.

Arguments paco6_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_unfold         [ T0 T1 T2 T3 T4 T5 ].

Instance paco6_inst  T0 T1 T2 T3 T4 T5 (gf : rel6 T0 T1 T2 T3 T4 T5->_) r x0 x1 x2 x3 x4 x5 : paco_class (paco6 gf r x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_acc gf;
  pacomult   := paco6_mult gf;
  pacofold   := paco6_fold gf;
  pacounfold := paco6_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg6_2.

Definition monotone6_2 T0 T1 T2 T3 T4 T5 (gf: rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5) :=
  forall x0 x1 x2 x3 x4 x5 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0 x1 x2 x3 x4 x5) (LE_0: r_0 <6= r'_0)(LE_1: r_1 <6= r'_1), gf r'_0 r'_1 x0 x1 x2 x3 x4 x5.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable gf_0 gf_1 : rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5.
Arguments gf_0 : clear implicits.
Arguments gf_1 : clear implicits.

Theorem paco6_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_2_0 gf_0 gf_1 rr r_1),
  l <6= paco6_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco6_2_0 gf_0 gf_1 (r_0 \6/ l) r_1 x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_2_1 gf_0 gf_1 r_0 rr),
  l <6= paco6_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco6_2_1 gf_0 gf_1 r_0 (r_1 \6/ l) x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_2_0_mon: monotone6_2 (paco6_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_2_1_mon: monotone6_2 (paco6_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_2_0_mult_strong: forall r_0 r_1,
  paco6_2_0 gf_0 gf_1 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_2_1_mult_strong: forall r_0 r_1,
  paco6_2_1 gf_0 gf_1 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Corollary paco6_2_0_mult: forall r_0 r_1,
  paco6_2_0 gf_0 gf_1 (paco6_2_0 gf_0 gf_1 r_0 r_1) (paco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco6_2_0_mult_strong, paco6_2_0_mon; eauto. Qed.

Corollary paco6_2_1_mult: forall r_0 r_1,
  paco6_2_1 gf_0 gf_1 (paco6_2_0 gf_0 gf_1 r_0 r_1) (paco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco6_2_1_mult_strong, paco6_2_1_mon; eauto. Qed.

Theorem paco6_2_0_fold: forall r_0 r_1,
  gf_0 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco6_2_1_fold: forall r_0 r_1,
  gf_1 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1) <6= paco6_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco6_2_0_unfold: forall (MON: monotone6_2 gf_0) (MON: monotone6_2 gf_1) r_0 r_1,
  paco6_2_0 gf_0 gf_1 r_0 r_1 <6= gf_0 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone6_2; intros; destruct PR; eauto. Qed.

Theorem paco6_2_1_unfold: forall (MON: monotone6_2 gf_0) (MON: monotone6_2 gf_1) r_0 r_1,
  paco6_2_1 gf_0 gf_1 r_0 r_1 <6= gf_1 (upaco6_2_0 gf_0 gf_1 r_0 r_1) (upaco6_2_1 gf_0 gf_1 r_0 r_1).
Proof. unfold monotone6_2; intros; destruct PR; eauto. Qed.

End Arg6_2.

Hint Unfold monotone6_2.
Hint Resolve paco6_2_0_fold.
Hint Resolve paco6_2_1_fold.

Arguments paco6_2_0_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_0_unfold         [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_2_1_unfold         [ T0 T1 T2 T3 T4 T5 ].

Instance paco6_2_0_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 x0 x1 x2 x3 x4 x5 : paco_class (paco6_2_0 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_2_0_acc gf_0 gf_1;
  pacomult   := paco6_2_0_mult gf_0 gf_1;
  pacofold   := paco6_2_0_fold gf_0 gf_1;
  pacounfold := paco6_2_0_unfold gf_0 gf_1 }.

Instance paco6_2_1_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 x0 x1 x2 x3 x4 x5 : paco_class (paco6_2_1 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_2_1_acc gf_0 gf_1;
  pacomult   := paco6_2_1_mult gf_0 gf_1;
  pacofold   := paco6_2_1_fold gf_0 gf_1;
  pacounfold := paco6_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg6_3.

Definition monotone6_3 T0 T1 T2 T3 T4 T5 (gf: rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5) :=
  forall x0 x1 x2 x3 x4 x5 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0 x1 x2 x3 x4 x5) (LE_0: r_0 <6= r'_0)(LE_1: r_1 <6= r'_1)(LE_2: r_2 <6= r'_2), gf r'_0 r'_1 r'_2 x0 x1 x2 x3 x4 x5.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable gf_0 gf_1 gf_2 : rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5 -> rel6 T0 T1 T2 T3 T4 T5.
Arguments gf_0 : clear implicits.
Arguments gf_1 : clear implicits.
Arguments gf_2 : clear implicits.

Theorem paco6_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <6= paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco6_3_0 gf_0 gf_1 gf_2 (r_0 \6/ l) r_1 r_2 x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <6= paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco6_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \6/ l) r_2 x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <6= rr) (CIH: l <_paco_6= rr), l <_paco_6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \6/ l) x0 x1 x2 x3 x4 x5) by eauto.
  clear PR; repeat (try left; do 7 paco_revert; paco_cofix_auto).
Qed.

Theorem paco6_3_0_mon: monotone6_3 (paco6_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_1_mon: monotone6_3 (paco6_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_2_mon: monotone6_3 (paco6_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_0_mult_strong: forall r_0 r_1 r_2,
  paco6_3_0 gf_0 gf_1 gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_1_mult_strong: forall r_0 r_1 r_2,
  paco6_3_1 gf_0 gf_1 gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Theorem paco6_3_2_mult_strong: forall r_0 r_1 r_2,
  paco6_3_2 gf_0 gf_1 gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 7 paco_revert; paco_cofix_auto). Qed.

Corollary paco6_3_0_mult: forall r_0 r_1 r_2,
  paco6_3_0 gf_0 gf_1 gf_2 (paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco6_3_0_mult_strong, paco6_3_0_mon; eauto. Qed.

Corollary paco6_3_1_mult: forall r_0 r_1 r_2,
  paco6_3_1 gf_0 gf_1 gf_2 (paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco6_3_1_mult_strong, paco6_3_1_mon; eauto. Qed.

Corollary paco6_3_2_mult: forall r_0 r_1 r_2,
  paco6_3_2 gf_0 gf_1 gf_2 (paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco6_3_2_mult_strong, paco6_3_2_mon; eauto. Qed.

Theorem paco6_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco6_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco6_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <6= paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco6_3_0_unfold: forall (MON: monotone6_3 gf_0) (MON: monotone6_3 gf_1) (MON: monotone6_3 gf_2) r_0 r_1 r_2,
  paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <6= gf_0 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone6_3; intros; destruct PR; eauto. Qed.

Theorem paco6_3_1_unfold: forall (MON: monotone6_3 gf_0) (MON: monotone6_3 gf_1) (MON: monotone6_3 gf_2) r_0 r_1 r_2,
  paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <6= gf_1 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone6_3; intros; destruct PR; eauto. Qed.

Theorem paco6_3_2_unfold: forall (MON: monotone6_3 gf_0) (MON: monotone6_3 gf_1) (MON: monotone6_3 gf_2) r_0 r_1 r_2,
  paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <6= gf_2 (upaco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (upaco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2).
Proof. unfold monotone6_3; intros; destruct PR; eauto. Qed.

End Arg6_3.

Hint Unfold monotone6_3.
Hint Resolve paco6_3_0_fold.
Hint Resolve paco6_3_1_fold.
Hint Resolve paco6_3_2_fold.

Arguments paco6_3_0_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_acc            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_mon            [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_mult_strong    [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_mult           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_fold           [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_0_unfold         [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_1_unfold         [ T0 T1 T2 T3 T4 T5 ].
Arguments paco6_3_2_unfold         [ T0 T1 T2 T3 T4 T5 ].

Instance paco6_3_0_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 gf_2 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 : paco_class (paco6_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco6_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco6_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco6_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco6_3_1_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 gf_2 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 : paco_class (paco6_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco6_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco6_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco6_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco6_3_2_inst  T0 T1 T2 T3 T4 T5 (gf_0 gf_1 gf_2 : rel6 T0 T1 T2 T3 T4 T5->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 : paco_class (paco6_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5) :=
{ pacoacc    := paco6_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco6_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco6_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco6_3_2_unfold gf_0 gf_1 gf_2 }.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export approx_star_props1.
(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)
(** printing $  $\times$ #×# *)
(** printing &  $\times$ #×# *)

Hint Resolve approx_star_relates_only_wf : slow.

Lemma alpha_implies_approx_star {p} :
  forall lib nt1 nt2,
  @nt_wf p nt1
  -> alpha_eq nt1 nt2
  -> approx_star lib nt1 nt2.
Proof.
  introv H1nt H2nt.
  apply approx_open_implies_approx_star.
  apply alpha_implies_approx_open; trivial.
Qed.

Lemma approx_star_trans {p} : forall lib t1 t2 t3,
  @approx_star p lib t1 t2
  -> approx_star lib t2 t3
  -> approx_star lib t1 t3.
Proof.
  nterm_ind1s t1 as [v1|f ind|o lbt1 Hind] Case; introv H1as H2as;
  inversion H1as as [? ? ? aop|?|]; subst; clear H1as.
Abort. (** see comments above for approx_star_open_trans*)

Lemma le_approx_ntwf {p} :
  forall lib, le_bin_rel (approx_star lib) (indep_bin_rel nt_wf (@nt_wf p)).
Proof.
  eauto with slow.
Qed.

Lemma approx_rel_wf_sub {p} :
  forall lib lvi lnta lntb,
  bin_rel_nterm (@approx_star p lib) lnta lntb
  -> wf_sub (combine lvi lnta) # wf_sub (combine lvi lntb).
Proof.
  introv Hb. apply (le_binrel_list_un _ _ _ _ (le_approx_ntwf lib)) in Hb.
  exrepnd. unfold wf_sub, sub_range_sat.   dands; eauto with slow.
Qed.

Lemma approx_star_btermd_fr {p} :
  forall lib op bt1 bt2 lva,
    op = NCan NFresh
    -> approx_star_bterm lib op bt1 bt2
    -> {lvn : list NVar
        & {nt1',nt2' : @NTerm p
        $ {sub : Sub
        $ approx_star lib (lsubst nt1' sub) (lsubst nt2' sub)
        # nrut_sub (get_utokens nt1' ++ get_utokens nt2') sub
        # lvn = dom_sub sub
        # alpha_eq_bterm bt1 (bterm lvn nt1')
        # alpha_eq_bterm bt2 (bterm lvn nt2')
        # no_repeats lvn
        (* # disjoint lvn (all_vars (get_nt bt1) ++ all_vars (get_nt bt2)) *)
        # disjoint (lvn ++ (bound_vars nt1') ++ (bound_vars nt2')) lva }}}.
Proof.
  introv d Hab.
  unfold approx_star_bterm in Hab.
  repnud Hab. exrepnd.
  pose proof (alpha_bterm_pair_change _ _ _ _ _ lva Hab2 Hab0) as Hp.
  exrepnd.
  exists lvn.

  repndors; exrepnd; subst; tcsp; GC.
  allrw disjoint_app_r; allrw disjoint_app_l; repnd.

  exists (lsubst nt1n (var_ren (dom_sub sub) lvn))
         (lsubst nt2n (var_ren (dom_sub sub) lvn))
         (combine lvn (range sub)).
  rw @boundvars_lsubst_vars; auto.
  rw @boundvars_lsubst_vars; auto.
  rw @get_utokens_lsubst_allvars; eauto 3 with slow.
  rw @get_utokens_lsubst_allvars; eauto 3 with slow.
  rw @dom_sub_combine; allrw @length_range; allrw @length_dom; auto.

  dands; eauto 3 with slow.

  - pose proof (lsubst_nest_same_alpha nt1n (dom_sub sub) lvn (range sub)) as nest1.
    allrw @length_dom; allrw @length_range.
    repeat (autodimp nest1 hyp).
    { apply alphaeq_preserves_free_vars in Hp2; rw <- Hp2; auto. }
    rw <- @sub_eta in nest1.

    pose proof (lsubst_nest_same_alpha nt2n (dom_sub sub) lvn (range sub)) as nest2.
    allrw @length_dom; allrw @length_range.
    repeat (autodimp nest2 hyp).
    { apply alphaeq_preserves_free_vars in Hp3; rw <- Hp3; auto. }
    rw <- @sub_eta in nest2.

    pose proof (lsubst_alpha_congr2 nt1 nt1n sub Hp2) as as1.
    pose proof (lsubst_alpha_congr2 nt2 nt2n sub Hp3) as as2.

    eapply approx_star_alpha_fun_l;[|apply alpha_eq_sym; exact nest1].
    eapply approx_star_alpha_fun_r;[|apply alpha_eq_sym; exact nest2].
    eauto 3 with slow.

  - apply alphaeq_preserves_utokens in Hp2.
    apply alphaeq_preserves_utokens in Hp3.
    rw <- Hp2; rw <- Hp3.
    eapply nrut_sub_change_sub_same_range;[|exact Hab5].
    rw @range_combine; auto; allrw @length_range; allrw @length_dom; auto.

  - allrw disjoint_app_l; dands; auto.
Qed.

(*
Lemma change_nr_ut_sub_in_lsubst_aux_approx_star {o} :
  forall lib (t1 t2 : @NTerm o) sub1 sub2 l,
    wf_term t1
    -> wf_term t2
    -> approx_star lib (lsubst_aux t1 sub1) (lsubst_aux t2 sub1)
    -> subset (get_utokens t1) l
    -> subset (get_utokens t2) l
    -> nrut_sub l sub1
    -> nrut_sub l sub2
    -> dom_sub sub1 = dom_sub sub2
    -> approx_star lib (lsubst_aux t1 sub2) (lsubst_aux t2 sub2).
Proof.
  nterm_ind1s t1 as [v|op bs ind] Case;
  introv w1 s2 ap ss1 ss2 nrut1 nrut2 eqdoms; allsimpl.

Focus 2.
{
  destruct t2 as [v2|op2 bs2]; allsimpl.

Focus 2.
{

}

  - pose proof (sub_find_some_eq_doms_nrut_sub sub1 sub2 v2 l) as e.
    repeat (autodimp e hyp).
    remember (sub_find sub1 v2) as sf; symmetry in Heqsf; destruct sf.

(*
Focus 2.
{
  rw e.
  inversion ap as [? ? ? ao|]; subst; clear ap.
  constructor.
       apply approx_open_vterm_iff_reduces_to in ao;
       [|apply lsubst_aux_preserves_wf_term2; eauto with slow];
       apply approx_open_vterm_iff_reduces_to;
       [apply lsubst_aux_preserves_wf_term2; eauto with slow|];
       apply (reduces_to_vterm_nrut_sub_change lib t2 sub1 sub2 l); auto
}
*)

    + exrepnd; rw e0.
      applydup @sub_find_some in Heqsf.
      eapply in_nrut_sub in Heqsf0; eauto.
      exrepnd; subst.
      inversion ap as [|? ? ? ? ? len lift apo]; subst; allsimpl; cpx; clear ap.
      allrw map_length.
      apply approx_open_simpler_equiv in apo.
      unfold simpl_olift in apo; repnd.
      pose proof (apo (ax_sub (free_vars (oterm op lbt1')))) as ap; clear apo.
      repeat (autodimp ap hyp).
      { apply isprogram_lsubst_prog_sub; eauto 3 with slow.
        rw @dom_sub_ax_sub; auto. }
      { rw @cl_lsubst_lsubst_aux; eauto 1 with slow.
        simpl; repeat constructor; simpl; sp. }
      repeat (rw @cl_lsubst_lsubst_aux in ap; eauto 1 with slow).
      simpl in ap.
      allfold (@mk_utoken o a0).

SearchAbout dom_sub ax_sub.
}

  - Case "vterm".
    pose proof (sub_find_some_eq_doms_nrut_sub sub1 sub2 v l) as h.
    repeat (autodimp h hyp).
    remember (sub_find sub1 v) as sf1; symmetry in Heqsf1; destruct sf1; exrepnd;
    [|rw h;
       inversion ap as [? ? ? ao|]; subst; clear ap;
       constructor;
       apply approx_open_vterm_iff_reduces_to in ao;
       [|apply lsubst_aux_preserves_wf_term2; eauto with slow];
       apply approx_open_vterm_iff_reduces_to;
       [apply lsubst_aux_preserves_wf_term2; eauto with slow|];
       apply (reduces_to_vterm_nrut_sub_change lib t2 sub1 sub2 l); auto
    ].

    rw h0.
    apply (apso _ _ _ _ []); simpl; auto; fold_terms.
    { unfold lblift_sub; simpl; tcsp. }
    dup Heqsf1 as i.
    apply sub_find_some in Heqsf1.
    eapply in_nrut_sub in Heqsf1; eauto; exrepnd; subst.
    assert (!LIn a0 (get_utokens t2)) as ni by (intro k; apply ss2 in k; sp).
    inversion ap as [|? ? ? ? ? len lift apo]; subst; allsimpl; cpx; clear lift ap.
    fold_terms.

    apply approx_open_simpler_equiv in apo.
    unfold simpl_olift in apo; repnd.

    apply approx_open_simpler_equiv.
    apply lsubst_aux_nt_wf in apo1.
    unfold simpl_olift; dands; eauto 3 with slow.
    introv ps isp1 isp2.
    rw (cl_lsubst_trivial (mk_utoken a)); simpl; eauto 3 with slow.

    (* replace the [a]s in sub by [a0]s to build a sub' and instantiate apo using that? *)

    rw <- @cl_lsubst_lsubst_aux; eauto 2 with slow.
    rw <- @cl_lsubst_lsubst_aux in isp2; eauto 2 with slow.
    rw @cl_lsubst_swap_sub_filter; eauto 2 with slow.
    rw @cl_lsubst_swap_sub_filter in isp2; eauto 2 with slow.
    remember (sub_filter sub (dom_sub sub2)) as sub0.

Lemma pull_out_nrut_sub_from_term {o} :
  forall (t : @NTerm o) (sub : @Sub o) l,
    nrut_sub l sub
    -> {t' : NTerm
        & t = lsubst t' sub
        # disjoint (get_utokens t) (get_utokens_sub sub)}.
Proof.
  nterm_ind t as [v|op bs ind] Case; introv nrut; allsimpl.

  - exists ([] : @Sub o); simpl; dands; auto.
    unfold get_utokens_sub; simpl; auto.

  - destruct x as [v t].
    pose proof (IHsub1 sub2 l nrut) as h; exrepnd.
Qed.

Lemma pull_out_nrut_sub_from_sub {o} :
  forall (sub1 sub2 : @Sub o) l,
    nrut_sub l sub2
    -> {sub : Sub
        & sub1 = lsubst_sub sub sub2
        # disjoint (get_utokens_sub sub) (get_utokens_sub sub2)}.
Proof.
  induction sub1 as [|x sub1]; introv nrut.

  - exists ([] : @Sub o); simpl; dands; auto.
    unfold get_utokens_sub; simpl; auto.

  - destruct x as [v t].
    pose proof (IHsub1 sub2 l nrut) as h; exrepnd.
Qed.

      remember (ren_utokens_sub (nrut_subs_to_utok_ren sub2 sub1) sub0) as sub0'.

      pose proof (dom_sub_ren_utokens_sub (nrut_subs_to_utok_ren sub2 sub1) sub0) as eqdoms0.
      rw <- Heqsub0' in eqdoms0.

      pose proof (apo sub0') as h; clear apo.
      rw <- @cl_lsubst_lsubst_aux in h; eauto 2 with slow.

      assertdimp h hh.
      { subst; eauto with slow. }
      rw @cl_lsubst_swap_sub_filter in h; eauto 2 with slow.
      rw eqdoms in h.
      rw @sub_filter_disjoint1 in h;
        [|rw eqdoms0; rw Heqsub0; rw <- @dom_sub_sub_filter; complete (eauto with slow)].
      rw (cl_lsubst_trivial (mk_utoken a0)) in h; simpl; eauto 2 with slow.

      repeat (assertdimp h hh); eauto 2 with slow.
      { apply (prog_sub_change sub2 sub1); eauto 2 with slow.
        apply lsubst_program_implies in isp2.
        unfold isprogram; dands.
        - unfold closed.
          rw @free_vars_cl_lsubst; eauto 2 with slow.
          apply null_iff_nil.
          apply null_remove_nvars_subvars.
          eapply subvars_eqvars;[|apply eqvars_sym; apply eqvars_free_vars_disjoint].
          rw eqdoms0.
          apply subvars_eq in isp2.
          eapply subvars_eqvars in isp2;[|apply eqvars_free_vars_disjoint].
          rw Heqsub0'.
          rw @sub_keep_first_ren_utokens_sub.
          rw @sub_free_vars_ren_utokens_sub; auto.
        - apply lsubst_wf_if_eauto; eauto with slow. }

      apply approx_utoken_implies_reduces_to in h.
      apply reduces_to_implies_approx1; auto.

(* pull out the atoms from [lsubst t2 sub0'] in [h]
   and from [lsubst t2 sub0] in the conclusion.
   Something like that, maybe:
 *)

Lemma xxx {o} :
  forall (t : @NTerm o) (sub sub1 sub2 : @Sub o) l,
    let sub' := ren_utokens_sub (nrut_subs_to_utok_ren sub2 sub1) sub in
    nrut_sub l sub1
    -> nrut_sub l sub2
    -> dom_sub sub1 = dom_sub sub2
    -> {sub0 : Sub
        & sub' = lsubst_sub sub0 sub1
        # sub  = lsubst_sub sub0 sub2
        # disjoint (get_utokens_sub sub1) (get_utokens_sub sub0)
        # disjoint (get_utokens_sub sub2) (get_utokens_sub sub0)}.

Check reduces_in_atmost_k_steps_change_utok_sub.

XXXXXXX

      unfold reduces_to in h; exrepnd.

(*
      pose proof (reduces_in_atmost_k_steps_change_utok_sub
                    lib k t (mk_utoken a0) sub1 sub2) as h.
      repeat (autodimp h hyp); eauto 3 with slow.
*)

(*
XXXXXXXXXXXXXXXXXX

      pose proof (apo sub) as h; clear apo.
      rw (cl_lsubst_trivial (mk_utoken a0)) in h; simpl; eauto 3 with slow.
      repeat (autodimp h hyp); eauto 2 with slow.
      { rw <- @cl_lsubst_lsubst_aux; eauto 2 with slow.
        rw <- @cl_lsubst_lsubst_aux in isp2; eauto 2 with slow.
        rw @cl_lsubst_swap_sub_filter in isp2; eauto 2 with slow.
        rw @cl_lsubst_swap_sub_filter; eauto 2 with slow.
        rw eqdoms.
        eapply prog_sub_change; eauto with slow. }

      rw <- @cl_lsubst_lsubst_aux in h; eauto 2 with slow.
      rw @cl_lsubst_swap_sub_filter in h; eauto 2 with slow.
      rw eqdoms in h.

      remember (lsubst t2 (sub_filter sub (dom_sub sub2))) as t.

      apply approx_utoken_implies_reduces_to in h.
      unfold reduces_to in h; exrepnd.
      pose proof (reduces_in_atmost_k_steps_change_utok_sub
                    lib k t (mk_utoken a0) sub1 sub2) as h.
      repeat (autodimp h hyp); eauto 3 with slow.

      assert (subset (get_utokens t) l) as ss3.
      {
        subst; introv j; apply get_utokens_lsubst in j.
        allrw in_app_iff; repndors; tcsp.
        rw @sub_keep_first_sub_filter in j.
        apply in_get_utokens_sub in j; exrepnd.
        apply in_sub_filter in j0; repnd.
        apply in_sub_keep_first in j2; repnd.

      }
*)

Abort.
*)

Lemma isprogram_ren_utokens_iff {o} :
  forall (ren : @utok_ren o) (t : NTerm),
    isprogram (ren_utokens ren t) <=> isprogram t.
Proof.
  introv; split; intro k; try (apply isprogram_ren_utokens); auto.
  allunfold @isprogram; repnd; allunfold @closed.
  allrw @free_vars_ren_utokens; dands; auto.
  allrw @nt_wf_ren_utokens_iff; auto.
Qed.

Lemma prog_sub_ren_utokens_sub_iff {o} :
  forall (ren : @utok_ren o) (sub : Sub),
    prog_sub (ren_utokens_sub ren sub) <=> prog_sub sub.
Proof.
  induction sub; allsimpl; tcsp.
  destruct a as [v t]; allsimpl; allrw @prog_sub_cons.
  rw IHsub; rw @isprogram_ren_utokens_iff; sp.
Qed.

Lemma approx_open_change_utoks {o} :
  forall lib (t1 t2 : @NTerm o) ren,
    no_repeats (range_utok_ren ren)
    -> no_repeats (dom_utok_ren ren)
    -> disjoint (range_utok_ren ren) (diff (get_patom_deq o) (dom_utok_ren ren) (get_utokens t1))
    -> disjoint (range_utok_ren ren) (diff (get_patom_deq o) (dom_utok_ren ren) (get_utokens t2))
    -> approx_open lib t1 t2
    -> approx_open lib (ren_utokens ren t1) (ren_utokens ren t2).
Proof.
  introv norep1 norep2 disj1 disj2 apo.

  allrw <- @approx_open_simpler_equiv.
  allunfold @simpl_olift.
  repnd.
  allrw @nt_wf_ren_utokens_iff; dands; auto.
  introv ps isp1 isp2.

  pose proof (ex_ren_utokens_sub
                sub
                ren
                (get_utokens t1 ++ get_utokens t2)) as exren.
  autodimp exren hyp; exrepnd.

  pose proof (apo sub') as h.
  repeat (autodimp h hyp).
  { subst; allrw @prog_sub_ren_utokens_sub_iff; auto. }
  { subst; apply isprogram_lsubst_iff in isp1; repnd.
    apply isprogram_lsubst_iff.
    rw @nt_wf_ren_utokens_iff in isp0; dands; auto.
    introv j.
    rw @free_vars_ren_utokens in isp1.
    apply isp1 in j; exrepnd.
    allrw @sub_find_ren_utokens_sub.
    remember (sub_find sub' v) as sf; symmetry in Heqsf; destruct sf; ginv.
    eexists; dands; eauto.
    - apply nt_wf_ren_utokens_iff in j2; auto.
    - unfold closed in j0; rw @free_vars_ren_utokens in j0; auto. }
  { subst; apply isprogram_lsubst_iff in isp2; repnd.
    apply isprogram_lsubst_iff.
    rw @nt_wf_ren_utokens_iff in isp0; dands; auto.
    introv j.
    rw @free_vars_ren_utokens in isp2.
    apply isp2 in j; exrepnd.
    allrw @sub_find_ren_utokens_sub.
    remember (sub_find sub' v) as sf; symmetry in Heqsf; destruct sf; ginv.
    eexists; dands; eauto.
    - apply nt_wf_ren_utokens_iff in j2; auto.
    - unfold closed in j0; rw @free_vars_ren_utokens in j0; auto. }

  pose proof (approx_change_utoks lib (lsubst t1 sub') (lsubst t2 sub') (ren ++ ren')) as k.
  allrw @range_utok_ren_app.
  allrw @dom_utok_ren_app.
  allrw no_repeats_app.
  allrw disjoint_app_l.
  allrw disjoint_app_r.
  repnd.
  repeat (autodimp k hyp); dands; eauto 3 with slow.

    { introv a b; applydup disj1 in a.
      allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
      apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
      apply in_get_utokens_sub in b0; exrepnd.
      apply in_sub_keep_first in b2; repnd.
      pose proof (exren1 t) as hh.
      repeat (autodimp hh hyp).
      rw lin_flat_map; apply sub_find_some in b3; apply in_sub_eta in b3; repnd.
      eexists; dands; eauto.
    }

    { eapply subset_disjoint;[exact exren4|].
      apply disjoint_app_l; dands.
      { apply disjoint_diff_l; rw diff_nil_if_subset; eauto with slow. }
      { apply disjoint_diff_l; rw diff_nil_if_subset; eauto with slow. }
    }

    { introv a b; applydup disj2 in a.
      allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
      apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
      apply in_get_utokens_sub in b0; exrepnd.
      apply in_sub_keep_first in b2; repnd.
      pose proof (exren1 t) as hh.
      repeat (autodimp hh hyp).
      rw lin_flat_map; apply sub_find_some in b3; apply in_sub_eta in b3; repnd.
      eexists; dands; eauto.
    }

    { eapply subset_disjoint;[exact exren4|].
      apply disjoint_app_l; dands.
      { apply disjoint_diff_l; rw diff_nil_if_subset; eauto with slow. }
      { apply disjoint_diff_l; rw diff_nil_if_subset; eauto with slow. }
    }

    { repeat (rw @lsubst_ren_utokens in k).
      rw exren0 in k.
      repeat (rw @ren_utokens_app_weak_l in k; eauto 2 with slow).
    }
Qed.

Definition utok_ren_cond2 {o} atoms (ren ren' : @utok_ren o) :=
  forall a,
    LIn a atoms
    -> LIn a (range_utok_ren ren)
    -> !LIn a (dom_utok_ren ren)
    -> LIn a (dom_utok_ren ren').

Definition utok_ren_cond2_nil {o} :
  forall (ren1 ren2 : @utok_ren o),
    utok_ren_cond2 [] ren1 ren2.
Proof.
  introv i j k; allsimpl; tcsp.
Qed.
Hint Resolve utok_ren_cond2_nil : slow.

Definition utok_ren_cond2_app {o} :
  forall atoms1 atoms2 (ren1 ren2 : @utok_ren o),
    utok_ren_cond2 atoms1 ren1 ren2
    -> utok_ren_cond2 atoms2 ren1 ren2
    -> utok_ren_cond2 (atoms1 ++ atoms2) ren1 ren2.
Proof.
  introv c1 c2 i j k; allsimpl; tcsp.
  allrw in_app_iff; repndors.
  - apply c1 in i; repeat (autodimp i hyp).
  - apply c2 in i; repeat (autodimp i hyp).
Qed.
Hint Resolve utok_ren_cond2_app : slow.

Lemma ex_ren_atom2 {o} :
  forall (a : get_patom_set o) ren atoms,
    {ren' : utok_ren
     & disjoint (range_utok_ren ren') (a :: atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
     # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
     # subset (dom_utok_ren ren') (range_utok_ren ren)
     # subset (dom_utok_ren ren') [a]
     # no_repeats (dom_utok_ren ren')
     # no_repeats (range_utok_ren ren')
     # utok_ren_cond2 [a] ren ren' }.
Proof.
  introv.
  destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)) as [d|d].

  - exists ([] : @utok_ren o); allsimpl; dands; tcsp.
    introv i j k; allsimpl; repndors; subst; tcsp.

  - destruct (in_deq _ (get_patom_deq o) a (range_utok_ren ren)) as [r|r].

    + pose proof (fresh_atom o (a :: atoms ++ dom_utok_ren ren ++ range_utok_ren ren)) as h.
      exrepnd.
      exists [(a,x)]; simpl.
      allrw disjoint_singleton_l.
      rw singleton_subset.
      dands; auto.
      introv i j k; allsimpl; repndors; subst; tcsp.

    + exists ([] : @utok_ren o); allsimpl; dands; tcsp.
      introv i j k; allsimpl; repndors; subst; tcsp.
Qed.

Lemma ex_ren_utokens_o2 {o} :
  forall (op : @Opid o) ren atoms,
    {ren' : utok_ren
     & disjoint (range_utok_ren ren') (get_utokens_o op ++ atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
     # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
     # subset (dom_utok_ren ren') (range_utok_ren ren)
     # subset (dom_utok_ren ren') (get_utokens_o op)
     # no_repeats (dom_utok_ren ren')
     # no_repeats (range_utok_ren ren')
     # utok_ren_cond2 (get_utokens_o op) ren ren' }.
Proof.
  introv.
  remember (get_utok op) as guo; symmetry in Heqguo; destruct guo.
  - apply get_utok_some in Heqguo; subst; allsimpl.
    pose proof (ex_ren_atom2 g ren atoms) as h; exrepnd.
    exists ren'; dands; auto.
  - exists ([] : @utok_ren o); allsimpl; dands; auto.
    apply get_utok_none in Heqguo; allrw; eauto with slow.
Qed.

Lemma ex_ren_utokens2 {o} :
  forall (t : @NTerm o) ren atoms,
    {ren' : utok_ren
     & disjoint (range_utok_ren ren') (get_utokens t ++ atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
     # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
     # subset (dom_utok_ren ren') (range_utok_ren ren)
     # subset (dom_utok_ren ren') (get_utokens t)
     # no_repeats (dom_utok_ren ren')
     # no_repeats (range_utok_ren ren')
     # utok_ren_cond2 (get_utokens t) ren ren' }.
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv.

  - Case "vterm".
    exists ([] : @utok_ren o); simpl; dands; eauto with slow.

  - Case "sterm".
    exists ([] : @utok_ren o); simpl; dands; eauto with slow.

  - Case "oterm".

    assert
      (forall atoms ren,
         {ren' : utok_ren
          & disjoint (range_utok_ren ren') (get_utokens_bs bs ++ atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
          # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
          # subset (dom_utok_ren ren') (range_utok_ren ren)
          # subset (dom_utok_ren ren') (get_utokens_bs bs)
          # no_repeats (dom_utok_ren ren')
          # no_repeats (range_utok_ren ren')
          # utok_ren_cond2 (get_utokens_bs bs) ren ren' }) as ebs.
    { clear ren atoms.
      induction bs; introv.
      - exists ([] : @utok_ren o); simpl; dands; eauto with slow.
      - destruct a as [l t].
        autodimp IHbs hyp.
        { introv i; apply (ind nt lv); eauto; simpl; sp. }
        pose proof (IHbs (atoms ++ get_utokens t) ren) as ibs; clear IHbs; exrepnd; allsimpl.
        pose proof (ind t l) as h; clear ind; autodimp h hyp.
        pose proof (h (ren ++ ren') (get_utokens_bs bs ++ atoms)) as k; clear h; exrepnd.
        exists (ren' ++ ren'0); simpl.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw no_repeats_app.
        allrw disjoint_app_l.
        allrw subset_app.
        allrw disjoint_app_r.
        allrw app_assoc.
        repnd; dands; eauto 2 with slow.

        {
          introv i; applydup k3 in i as j; allrw in_app_iff; repndors; tcsp.
          apply k4 in i; apply ibs8 in j; sp.
        }

        {
          apply utok_ren_cond2_app; auto.
          - introv i j k.
            applydup k0 in i.
            allrw @range_utok_ren_app.
            allrw @dom_utok_ren_app.
            allrw in_app_iff; allrw not_over_or.
            destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')) as [d|d]; tcsp.
          - introv i j k.
            applydup ibs0 in i.
            allrw @dom_utok_ren_app; allrw in_app_iff.
            repeat (autodimp i0 hyp).
        }
    }

    pose proof (ebs (atoms ++ get_utokens_o op) ren) as ebs'; clear ebs; exrepnd.

    pose proof (ex_ren_utokens_o2 op (ren ++ ren') (get_utokens_bs bs ++ atoms)) as eop; exrepnd.
    allrw @range_utok_ren_app.
    allrw @dom_utok_ren_app.
    allrw disjoint_app_l; repnd.
    allrw disjoint_app_r; repnd.

    exists (ren' ++ ren'0); simpl.
    allrw @range_utok_ren_app.
    allrw @dom_utok_ren_app.
    allrw no_repeats_app.
    allrw subset_app.
    allrw disjoint_app_l; allrw disjoint_app_r.
    repeat (rw app_assoc).
    dands; eauto 3 with slow.

    {
      introv i; applydup eop3 in i as j; allrw in_app_iff; repndors; tcsp.
      apply eop4 in i; apply ebs'8 in j; sp.
    }

    {
      apply utok_ren_cond2_app; auto.
      - introv i j k.
        applydup eop0 in i.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw in_app_iff; allrw not_over_or.
        destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')) as [d|d]; tcsp.
      - introv i j k.
        applydup ebs'0 in i.
        allrw @dom_utok_ren_app; allrw in_app_iff.
        repeat (autodimp i0 hyp).
    }
Qed.

Lemma ex_ren_utokens_sub2 {o} :
  forall (sub : @Sub o) ren atoms,
    {ren' : utok_ren
     & disjoint (range_utok_ren ren') (get_utokens_sub sub ++ atoms ++ dom_utok_ren ren ++ range_utok_ren ren)
     # disjoint (dom_utok_ren ren') (dom_utok_ren ren)
     # subset (dom_utok_ren ren') (range_utok_ren ren)
     # subset (dom_utok_ren ren') (get_utokens_sub sub)
     # no_repeats (dom_utok_ren ren')
     # no_repeats (range_utok_ren ren')
     # utok_ren_cond2 (get_utokens_sub sub) ren ren' }.
Proof.
  induction sub; introv.
  - exists ([] : @utok_ren o); simpl; rw @get_utokens_sub_nil; dands; eauto with slow.
  - destruct a as [v t]; allsimpl.
    pose proof (IHsub ren (atoms ++ get_utokens t)) as ih; clear IHsub; exrepnd.

    pose proof (ex_ren_utokens2 t (ren ++ ren') (get_utokens_sub sub ++ atoms)) as h; exrepnd.

    exists (ren' ++ ren'0); simpl.
    repeat (rw app_assoc).
    allrw @range_utok_ren_app.
    allrw @dom_utok_ren_app.
    allrw no_repeats_app.
    allrw @get_utokens_sub_cons.
    allrw disjoint_app_l; allrw disjoint_app_r.
    allrw subset_app.

    repnd; dands; eauto 3 with slow.

    {
      introv i; applydup h3 in i as j; allrw in_app_iff; repndors; tcsp.
      apply h4 in i; apply ih8 in j; sp.
    }

    {
      apply utok_ren_cond2_app; auto.
      - introv i j k.
        applydup h0 in i.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw in_app_iff; allrw not_over_or.
        destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')) as [d|d]; tcsp.
      - introv i j k.
        applydup ih0 in i.
        allrw @dom_utok_ren_app; allrw in_app_iff.
        repeat (autodimp i0 hyp).
    }
Qed.

Lemma ren_utokens_o_app_weak_l {o} :
  forall (op : @Opid o) ren1 ren2,
    disjoint (dom_utok_ren ren2) (get_utokens_o op)
    -> ren_utok_op (ren1 ++ ren2) op
       = ren_utok_op ren1 op.
Proof.
  introv disj.
  destruct op; tcsp.
  destruct c; tcsp.
  allsimpl.
  allrw disjoint_cons_r; repnd.
  rw @ren_atom_app_weak_l; auto.
Qed.

Lemma length_ren_utokens_bs {o} :
  forall (bs : list (@BTerm o)) ren,
    length (ren_utokens_bs ren bs) = length bs.
Proof.
  induction bs; introv; allsimpl; tcsp.
Qed.

Lemma ren_utok_op_diff_fresh {o} :
  forall (op : @Opid o) ren,
    (ren_utok_op ren op = NCan NFresh) <=> (op = NCan NFresh).
Proof.
  introv; split; intro e; subst; tcsp.
  destruct op; tcsp.
  destruct c; tcsp.
  allsimpl; ginv.
Qed.

Lemma ut_sub_ren_utokens_sub {o} :
  forall (sub : @Sub o) ren,
    ut_sub sub
    -> ut_sub (ren_utokens_sub ren sub).
Proof.
  induction sub; introv uts; allsimpl; tcsp.
  destruct a as [v t]; allrw @ut_sub_cons; repnd; dands; tcsp.
  allunfold @isutoken; exrepnd; subst; allsimpl; fold_terms.
  eexists; dands; eauto.
Qed.
Hint Resolve ut_sub_ren_utokens_sub : slow.

Lemma nrut_sub_implies_ut_sub {o} :
  forall (sub : @Sub o) l,
    nrut_sub l sub -> ut_sub sub.
Proof.
  introv nrut; unfold nrut_sub in nrut; sp.
Qed.
Hint Resolve nrut_sub_implies_ut_sub : slow.

Lemma utok_ren_cond_app_iff {o} :
  forall (atoms1 atoms2 : list (get_patom_set o)) (ren : utok_ren),
    utok_ren_cond (atoms1 ++ atoms2) ren
    <=> (utok_ren_cond atoms1 ren # utok_ren_cond atoms2 ren).
Proof.
  introv; split; intro k; try (apply utok_ren_cond_app; tcsp).
  dands; introv i j; pose proof (k a) as h; allrw in_app_iff; tcsp.
Qed.

Lemma false_if_utok_ren_cond_on_eq_ren_atoms {o} :
  forall ren (a b : @get_patom_set o) atoms1 atoms2,
    no_repeats (range_utok_ren ren)
    -> utok_ren_cond atoms1 ren
    -> utok_ren_cond atoms2 ren
    -> disjoint atoms1 atoms2
    -> LIn a atoms1
    -> LIn b atoms2
    -> ren_atom ren a = ren_atom ren b
    -> False.
Proof.
  introv nrr cond1 cond2 disj ia ib e.
  destruct (get_patom_deq o a b) as [x|x]; subst; tcsp.
  { apply disj in ib; sp. }

  pose proof (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)) as [d1|d1];
    pose proof (in_deq _ (get_patom_deq o) b (dom_utok_ren ren)) as [d2|d2].

  + apply ren_atom_eq1 in e; sp.

  + rw (ren_atom_not_in ren b) in e; auto.

    pose proof (in_deq _ (get_patom_deq o) b (range_utok_ren ren)) as [r|r].

    * pose proof (cond2 b) as h; allsimpl; repeat (autodimp h hyp).

    * pose proof (in_dom_in_range ren a d1) as h.
      rw e in h; sp.

  + rw (ren_atom_not_in ren a) in e; auto.

    pose proof (in_deq _ (get_patom_deq o) a (range_utok_ren ren)) as [r|r].

    * pose proof (cond1 a) as h; allsimpl; repeat (autodimp h hyp).

    * pose proof (in_dom_in_range ren b d2) as h.
      rw <- e in h; sp.

  + rw (ren_atom_not_in ren a) in e; auto.
    rw (ren_atom_not_in ren b) in e; auto.
Qed.

Lemma no_repeats_get_utokens_ren_utokens {o} :
  forall (t : @NTerm o) ren,
    no_repeats (range_utok_ren ren)
    -> no_repeats (get_utokens t)
    -> utok_ren_cond (get_utokens t) ren
    -> no_repeats (get_utokens (ren_utokens ren t)).
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv nrr nrt cond; allsimpl; auto.
  Case "oterm".
  allrw no_repeats_app; repnd; dands; eauto 3 with slow.

  - destruct op; tcsp.
    destruct c; allsimpl; tcsp.

  - rw flat_map_map; unfold compose.

    induction bs; allsimpl; tcsp.
    allrw disjoint_app_r; repnd.
    allrw no_repeats_app; repnd.
    repeat (autodimp IHbs hyp).
    { introv i nr1 nr2; eapply ind; eauto. }
    { allrw @utok_ren_cond_app_iff; tcsp. }
    dands; eauto 3 with slow.

    + destruct a as [l t]; allsimpl.
      eapply ind; eauto.
      allrw @utok_ren_cond_app_iff; tcsp.

    + destruct a as [l1 t1]; allsimpl.
      allrw disjoint_flat_map_r.
      introv i; destruct x as [l2 t2]; allsimpl.
      applydup nrt1 in i; allsimpl.
      allrw @get_utokens_ren_utokens.
      apply disjoint_map_l; introv a b; allrw in_map_iff; exrepnd.

      allrw @utok_ren_cond_app_iff; repnd.
      pose proof (false_if_utok_ren_cond_on_eq_ren_atoms
                    ren x a0 (get_utokens t1) (get_utokens t2)) as h.
      repeat (autodimp h hyp).
      introv p q; apply cond; auto.
      rw lin_flat_map; eexists; dands; eauto.

  - destruct op; try (complete (allsimpl; tcsp)).
    destruct c; allsimpl; tcsp.
    allrw disjoint_singleton_l.
    intro i.
    allrw flat_map_map; allunfold @compose.
    allrw lin_flat_map; exrepnd.
    destruct x as [l t]; allsimpl.
    allrw @get_utokens_ren_utokens; allrw in_map_iff; exrepnd.

    rw cons_as_app in cond.
    allrw @utok_ren_cond_app_iff; repnd.

    pose proof (false_if_utok_ren_cond_on_eq_ren_atoms
                  ren g a [g] (get_utokens t)) as h.
    repeat (autodimp h hyp); allsimpl; tcsp.

    + introv p q; apply cond; auto.
      rw lin_flat_map; eexists; dands; eauto.

    + apply disjoint_singleton_l; intro i.
      destruct nrt; eexists; dands; eauto; simpl; auto.
Qed.

Lemma get_utokens_sub_ren_utokens_sub {o} :
  forall (sub : @Sub o) ren,
    get_utokens_sub (ren_utokens_sub ren sub)
    = map (ren_atom ren) (get_utokens_sub sub).
Proof.
  induction sub; introv; allsimpl; tcsp.
  destruct a as [v t]; allsimpl.
  allrw @get_utokens_sub_cons; allrw map_app.
  rw IHsub.
  rw @get_utokens_ren_utokens; auto.
Qed.

Lemma no_repeats_get_utokens_sub_ren_utokens_sub {o} :
  forall (sub : @Sub o) ren,
    no_repeats (range_utok_ren ren)
    -> no_repeats (get_utokens_sub sub)
    -> utok_ren_cond (get_utokens_sub sub) ren
    -> no_repeats (get_utokens_sub (ren_utokens_sub ren sub)).
Proof.
  induction sub; introv nrr nrs cond; allsimpl;
  allrw @get_utokens_sub_nil; auto.
  destruct a as [v t]; allrw @get_utokens_sub_cons.
  allrw @utok_ren_cond_app_iff; repnd.
  allrw no_repeats_app; dands; repnd; eauto 3 with slow.
  - apply no_repeats_get_utokens_ren_utokens; auto.
  - allrw @get_utokens_ren_utokens.
    allrw @get_utokens_sub_ren_utokens_sub.
    clear IHsub.
    remember (get_utokens t) as atoms1; clear Heqatoms1.
    remember (get_utokens_sub sub) as atoms2; clear Heqatoms2.
    introv i j.
    allrw in_map_iff; exrepnd; subst.
    pose proof (false_if_utok_ren_cond_on_eq_ren_atoms
                  ren a0 a atoms2 atoms1) as h.
    repeat (autodimp h hyp); eauto with slow.
Qed.
Hint Resolve no_repeats_get_utokens_sub_ren_utokens_sub : slow.

Lemma nrut_sub_implies_no_repeats {o} :
  forall (sub : @Sub o) l,
    nrut_sub l sub
    -> no_repeats (get_utokens_sub sub).
Proof.
  introv nr; unfold nrut_sub in nr; sp.
Qed.
Hint Resolve nrut_sub_implies_no_repeats : slow.

Lemma change_nr_ut_sub_in_lsubst_aux_approx_star {o} :
  forall lib (t1 t2 : @NTerm o) ren,
    no_repeats (range_utok_ren ren)
    -> no_repeats (dom_utok_ren ren)
    -> disjoint (range_utok_ren ren) (diff (get_patom_deq o) (dom_utok_ren ren) (get_utokens t1))
    -> disjoint (range_utok_ren ren) (diff (get_patom_deq o) (dom_utok_ren ren) (get_utokens t2))
    -> approx_star lib t1 t2
    -> approx_star lib (ren_utokens ren t1) (ren_utokens ren t2).
Proof.
  nterm_ind1s t1 as [v1|f1 ind1|op1 bs1 ind1] Case; introv norep1 norep2 disj1 disj2 apr.

  - Case "vterm".
    allsimpl.
    constructor.
    inversion apr as [? ? ? apo|?|]; subst; clear apr.

    pose proof (approx_open_change_utoks lib (vterm v1) t2 ren) as h.
    repeat (autodimp h hyp).

  - Case "sterm".
    allsimpl.
    inversion apr as [|? ? ? ? imp aop|]; subst; clear apr.
    econstructor; eauto.
    apply (approx_open_change_utoks _ _ _ ren) in aop; auto.

  - Case "oterm".
    inversion apr as [|?|? ? ? ? ? len lift apo]; subst.

    pose proof (ex_ren_utokens2
                  (oterm op1 lbt1')
                  ren
                  (get_utokens (oterm op1 bs1) ++ get_utokens t2))
      as extra_ren; exrepnd.
    allsimpl; allrw disjoint_app_r; repnd.

    pose proof (approx_open_change_utoks lib (oterm op1 lbt1') t2 (ren ++ ren')) as h.
    allrw @range_utok_ren_app.
    allrw @dom_utok_ren_app.
    allrw no_repeats_app.
    allrw disjoint_app_l; allrw disjoint_app_r.
    repeat (autodimp h hyp); dands; eauto 3 with slow.

    { introv i j; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
      pose proof (extra_ren0 t) as h; allrw in_app_iff; repeat (autodimp h hyp). }

    { introv i j; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
      applydup extra_ren12 in i.
      applydup extra_ren7 in i.
      repndors; tcsp. }

    { introv i j; apply disj2 in i; allrw in_diff; allrw in_app_iff; allrw not_over_or; tcsp. }

    { introv i j; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
      apply extra_ren8 in i; sp. }

    allsimpl.
    rw (ren_utokens_app_weak_l t2) in h;
      [|introv i j; applydup extra_ren3 in i;
        applydup disj2 in i0; allrw in_diff; tcsp].
    rw (ren_utokens_o_app_weak_l op1) in h;
      [|introv i j; applydup extra_ren3 in i;
        applydup disj1 in i0; allrw in_diff;
        allrw in_app_iff; tcsp].

    apply (apso _ _ _ _ (ren_utokens_bs (ren ++ ren') lbt1'));
    allrw map_length; allrw @length_ren_utokens_bs; auto.

    allunfold @lblift_sub;
    allrw map_length; allrw @length_ren_utokens_bs;
    repnd; dands; auto.

    introv i.
    applydup lift in i; clear lift.
    allunfold @blift_sub; exrepnd.
    exists lv (ren_utokens ren nt1) (ren_utokens (ren ++ ren') nt2).
    dands; auto;
    [|rw @selectbt_map; auto;
      apply (alpha_eq_bterm_ren_utokens_b _ _ ren) in i2;
      allsimpl; auto
     |unfold ren_utokens_bs; rw @selectbt_map; auto; try omega;
      apply (alpha_eq_bterm_ren_utokens_b _ _ (ren ++ ren')) in i1;
      allsimpl; auto].

    pose proof (selectbt_in n bs1) as in1; autodimp in1 hyp.
    pose proof (selectbt_in n lbt1') as in2; autodimp in2 hyp; try omega.
    remember (selectbt bs1 n) as b1.
    remember (selectbt lbt1' n) as b2.
    destruct b1 as [l1 u1]; destruct b2 as [l2 u2].
    applydup @alpha_eq_bterm_preserves_osize in i2 as sz1.
    applydup @alpha_eq_bterm_preserves_osize in i1 as sz2.

    assert (subset (get_utokens nt1) (get_utokens_bs bs1)) as ss1.
    { introv a; unfold get_utokens_bs.
      rw lin_flat_map; eexists; dands; eauto; simpl.
      apply alpha_eq_bterm_preserves_utokens in i2; allsimpl; rw i2; auto. }

    assert (subset (get_utokens nt2) (get_utokens_bs lbt1')) as ss2.
    { introv a; unfold get_utokens_bs.
      rw lin_flat_map; eexists; dands; eauto; simpl.
      apply alpha_eq_bterm_preserves_utokens in i1; allsimpl; rw i1; auto. }

    repndors;exrepnd;[left|right].

    + dands; auto;[intro e; apply ren_utok_op_diff_fresh in e; auto|].
      pose proof (ind1 u1 nt1 l1) as q; clear ind1.
      rw sz1 in q.
      repeat (autodimp q hyp); eauto 3 with slow.
      pose proof (q nt2 (ren ++ ren')) as aprs; clear q.
      allrw @range_utok_ren_app.
      allrw @dom_utok_ren_app.
      allrw no_repeats_app.
      allrw disjoint_app_l; allrw disjoint_app_r.
      repeat (autodimp aprs hyp); dands; eauto 3 with slow.

      { introv a b; apply disj1 in a; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd; tcsp. }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply extra_ren10 in a; sp. }

      { introv a b; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
        pose proof (extra_ren0 t) as q; allrw in_app_iff; repeat (autodimp q hyp). }

      { introv a b; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
        applydup extra_ren7 in a; tcsp. }

      rw (ren_utokens_app_weak_l nt1) in aprs; auto.

      introv a b.
      applydup extra_ren3 in a.
      applydup extra_ren2 in a.
      applydup disj1 in a0; allrw in_diff; destruct a2; dands; tcsp.
      rw in_app_iff; right; rw lin_flat_map; eexists; dands; eauto; simpl.
      apply alpha_eq_bterm_preserves_utokens in i2; allsimpl; rw i2; auto.

    + pose proof (ex_ren_utokens_sub2
                    sub
                    (ren ++ ren')
                    (get_utokens nt1
                                 ++ get_utokens nt2
                                 ++ get_utokens (lsubst nt1 sub)
                                 ++ get_utokens (lsubst nt2 sub)))
        as extra_ren'; exrepnd.
      allsimpl; allrw disjoint_app_r; repnd.

      pose proof (ind1 u1 (lsubst nt1 sub) l1) as ih; clear ind1.
      rw sz1 in ih; repeat (autodimp ih hyp).
      { rw @simple_osize_lsubst; eauto with slow. }
      pose proof (ih (lsubst nt2 sub) ((ren ++ ren') ++ ren'0)) as q; clear ih.

      allrw @range_utok_ren_app.
      allrw @dom_utok_ren_app.
      allrw no_repeats_app.
      allrw disjoint_app_l; allrw disjoint_app_r.
      repnd; repeat (autodimp q hyp); dands; eauto 3 with slow.

      { introv a b; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
        apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
        - applydup ss1 in b0.
          applydup disj1 in a.
          allrw in_diff; allrw in_app_iff; allrw not_over_or; sp.
        - apply in_get_utokens_sub in b0; exrepnd.
          apply in_sub_keep_first in b3; repnd.
          apply sub_find_some in b4.
          pose proof (extra_ren'0 t) as r.
          allrw @range_utok_ren_app; allrw @dom_utok_ren_app.
          allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
          apply in_get_utokens_sub.
          eexists; eexists; dands; eauto.
      }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
        - applydup ss1 in b0; tcsp.
          apply extra_ren10 in a; tcsp.
        - apply in_get_utokens_sub in b0; exrepnd.
          apply in_sub_keep_first in b3; repnd.
          apply sub_find_some in b4.
          pose proof (extra_ren'0 t) as r.
          allrw @range_utok_ren_app; allrw @dom_utok_ren_app.
          allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
          apply in_get_utokens_sub.
          eexists; eexists; dands; eauto.
      }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply extra_ren'12 in a; sp.
      }

      { introv a b; allrw in_diff; allsimpl; allrw in_app_iff; allrw not_over_or; repnd.
        apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
        - applydup ss2 in b0.
          pose proof (extra_ren0 t) as q; allrw in_app_iff.
          repeat (autodimp q hyp); tcsp.
        - apply in_get_utokens_sub in b0; exrepnd.
          apply in_sub_keep_first in b3; repnd.
          apply sub_find_some in b4.
          pose proof (extra_ren'0 t) as r.
          allrw @range_utok_ren_app; allrw @dom_utok_ren_app.
          allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
          apply in_get_utokens_sub.
          eexists; eexists; dands; eauto.
      }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply get_utokens_lsubst in b0; allrw in_app_iff; repndors; tcsp.
        - applydup ss2 in b0.
          apply extra_ren7 in a; tcsp.
        - apply in_get_utokens_sub in b0; exrepnd.
          apply in_sub_keep_first in b3; repnd.
          apply sub_find_some in b4.
          pose proof (extra_ren'0 t) as r.
          allrw @range_utok_ren_app; allrw @dom_utok_ren_app.
          allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
          apply in_get_utokens_sub.
          eexists; eexists; dands; eauto.
      }

      { introv a b; allrw in_diff; allrw in_app_iff; allrw not_over_or; repnd.
        apply extra_ren'8 in a; sp.
      }

      repeat (rw @lsubst_ren_utokens in q).

      assert (disjoint (dom_utok_ren ren'0) (get_utokens nt1)) as disj'0nt1.
      { introv a b.
        applydup extra_ren'3 in a.
        applydup extra_ren'2 in a.
        allrw in_app_iff.
        repndors; tcsp.
        - applydup extra_ren'13 in a.
          applydup disj1 in a0; allrw in_diff; allrw in_app_iff; allrw not_over_or.
          destruct a3; dands; tcsp.
        - apply extra_ren10 in a0; tcsp.
      }

      pose proof (ren_utokens_app_weak_l nt1 (ren ++ ren') ren'0 disj'0nt1) as e1.
      rw e1 in q.

      assert (disjoint (dom_utok_ren ren') (get_utokens nt1)) as disj'nt1.
      { introv a b.
        applydup extra_ren3 in a.
        applydup extra_ren2 in a.
        applydup disj1 in a0; allrw in_diff; destruct a2; dands; tcsp.
        rw in_app_iff; right; rw lin_flat_map; eexists; dands; eauto; simpl.
        apply alpha_eq_bterm_preserves_utokens in i2; allsimpl; rw i2; auto.
      }

      pose proof (ren_utokens_app_weak_l nt1 ren ren' disj'nt1) as e2.
      rw e2 in q.

      assert (disjoint (dom_utok_ren ren'0) (get_utokens nt2)) as disj'0nt2.
      { introv a b.
        applydup extra_ren'3 in a.
        applydup extra_ren'2 in a.
        allrw in_app_iff.
        repndors; tcsp.
        - applydup extra_ren'13 in a.
          pose proof (extra_ren0 t) as r; allrw in_app_iff.
          repeat (autodimp r hyp); tcsp.
        - apply extra_ren7 in a0; tcsp.
      }

      pose proof (ren_utokens_app_weak_l nt2 (ren ++ ren') ren'0 disj'0nt2) as e3.
      rw e3 in q.

      exists (ren_utokens_sub ((ren ++ ren') ++ ren'0) sub).
      rw @ren_utok_op_diff_fresh.
      rw @dom_sub_ren_utokens_sub.
      dands; auto.

      assert (no_repeats (range_utok_ren ((ren ++ ren') ++ ren'0))) as norep_ren.
      { repeat (rw @range_utok_ren_app).
        repeat (rw no_repeats_app).
        rw disjoint_app_l; dands; eauto with slow. }

      assert (utok_ren_cond (get_utokens_sub sub) ((ren ++ ren') ++ ren'0)) as cond1.
      { introv x y.
        pose proof (extra_ren'0 a) as r.
        allrw @dom_utok_ren_app; allrw @range_utok_ren_app.
        allrw in_app_iff; allrw not_over_or.
        repndors.
        - destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)); tcsp.
          destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')); tcsp.
        - destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)); tcsp.
          destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren')); tcsp.
        - apply extra_ren'7 in y; sp. }

      assert (utok_ren_cond (get_utokens nt1) ren) as cond2.
      { introv x y.
        applydup ss1 in x.
        applydup disj1 in y.
        rw in_diff in y0; rw in_app_iff in y0.
        destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)); tcsp.
        destruct y0; dands; tcsp.
      }

      assert (utok_ren_cond (get_utokens nt2) (ren ++ ren')) as cond3.
      { introv x y.
        applydup ss2 in x.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        pose proof (extra_ren0 a) as r.
        allrw in_app_iff.
        destruct (in_deq _ (get_patom_deq o) a (dom_utok_ren ren)); tcsp.
        repndors; tcsp.
        clear r.
        apply extra_ren7 in y; sp.
      }

      unfold nrut_sub; dands; eauto 3 with slow.

      rw <- e3; rw <- e2; rw <- e1.
      repeat (rw @get_utokens_ren_utokens).
      rw @get_utokens_sub_ren_utokens_sub.
      rw <- map_app.
      apply disjoint_map_l; introv u v.
      rw in_map_iff in v; exrepnd.

      pose proof (false_if_utok_ren_cond_on_eq_ren_atoms
                    ((ren ++ ren') ++ ren'0)
                    x a
                    (get_utokens nt1 ++ get_utokens nt2)
                    (get_utokens_sub sub)) as hh.
      allunfold @nrut_sub; repnd.
      repeat (autodimp hh hyp); tcsp.

      clear u.
      apply utok_ren_cond_app.

      { introv z w.
        applydup cond2 in z.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw in_app_iff.
        repndors; tcsp.
        - apply extra_ren10 in w.
          apply ss1 in z; sp.
        - apply extra_ren'10 in w; sp.
      }

      { introv z w.
        applydup cond3 in z.
        allrw @range_utok_ren_app.
        allrw @dom_utok_ren_app.
        allrw in_app_iff.
        repndors; tcsp.
        apply extra_ren'11 in w; sp.
      }
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal71.

Set Printing Depth 1000.
Definition lfind_eval :=
@eq.

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .


Require Import String.
Require Import ExtLib.Data.Strings.
Require Import CoqCompile.Parse.
Require Import CoqCompile.Lambda.
Require Import CoqCompile.CpsKConvert.
Require Import CoqCompile.CpsCommon.
Require Import CoqCompile.Cps.
Require Import CoqCompile.CpsK.
Require Import CoqCompile.CpsKExamples.
Require Import CoqCompile.CloConvK.
Require Import CoqCompile.CpsK2Low.
Require Import CoqCompile.Low.

(*
Extraction Language Scheme.
Recursive Extraction fact.
*)

Definition lambda2low (e:option Lambda.exp) : string.
refine (
  match e with
    | Some e =>
      let cps_e := CpsKConvert.CPS_io e in
      match CPSK.exp_sane (m' := sum string) cps_e with
        | inl err => "CpsConv: " ++ err ++ (String Char.chr_newline (CPSK.exp2string cps_e))
        | inr _ =>
          match ClosureConvert.cloconv_exp cps_e with
            | inl ex => "CloConv: " ++ ex ++ (String Char.chr_newline (CPSK.exp2string cps_e))
            | inr (ds, e) => (* CPSK.exp2string e *)
              match @cpsk2low (sum string) _ _ ds e with
                | inl ex => "Lower: " ++ ex ++ (String Char.chr_newline (CPSK.exp2string cps_e)) (* (String Char.chr_newline (CPSK.exp2string (CPSK.Letrec_e ds e))) *)
                | inr prog => string_of_program prog
              end
          end
      end
    | None => "Parsing failed"%string
  end%string
).
Defined.

Eval compute in lambda2low (Some plus_lam).
Eval compute in lambda2low (Some mult_lam).
Eval compute in lambda2low (Some fact_lam).

Definition identity : string := "(define ident33 (lambda (x) x))"%string.
Definition identity_e := Parse.parse_topdecls identity.
Eval vm_compute in lambda2low identity_e.


Require Import Template.All.
Require Import List.
Import ListNotations.

(* Taken from the template-coq parametricity translation *)

Definition tsl_table := list (global_reference * term).

Fixpoint lookup_tsl_table (E : tsl_table) (gr : global_reference)
  : option term :=
  match E with
  | nil => None
  | hd :: tl =>
    if gref_eq_dec gr (fst hd) then Some (snd hd)
    else lookup_tsl_table tl gr
  end.

Definition default_term := tVar "constant_not_found".

Definition lookup_default (E : tsl_table) (gr : global_reference)
  : term :=
  match (lookup_tsl_table E gr) with
  | None => default_term
  | Some t => t
  end.

(* Partly taken from Template.Typing *)
Fixpoint it_mkLambda_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tLambda d.(decl_name) d.(decl_type) acc
       | Some b => tLetIn d.(decl_name) b d.(decl_type) acc
       end) l t.

Fixpoint it_mkProd_or_LetIn (t : term) (l : context) :=
  List.fold_left
    (fun acc d =>
       match d.(decl_body) with
       | None => tProd d.(decl_name) d.(decl_type) acc
       | Some b => tLetIn d.(decl_name) b d.(decl_type) acc
       end) l t.

Fixpoint fold_map_internal {A B C : Type} (f : A -> B -> A * C) (a : A)
         (cs : list C) (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, rev cs)
     | hd :: tl => let (a_, c_) := f a hd in fold_map_internal f a_ (c_ :: cs) tl
     end.

Definition fold_map {A B C : Type} (f : A -> B -> A * C) (a : A)
           (bs : list B) : A * (list C) := fold_map_internal f a [] bs.

Fixpoint fold_map' {A B C : Type} (f : A -> B -> A * C) (a : A)
         (bs : list B) : A * (list C)
  := match bs with
     | [] => (a, [])
     | hd :: tl => let (a_, c_) := f a hd in
                   let (a__, cs) := fold_map' f a_ tl in
                   (a__, c_ :: cs)
     end.

Example ex_fold_map : fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = (6,[2;3;4]).
reflexivity.
Qed.

Example ex_fold_map_fold_map' :
  fold_map (fun x y => (x+y, y+1)) 0 [1;2;3] = fold_map' (fun x y => (x+y, y+1)) 0 [1;2;3].
reflexivity.
Qed.