Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Tree.
Require Import String.
Require Import Asm.

Require TransExpression.
Require TransBranchInfo.

Local Open Scope error_monad_scope.

Set Implicit Arguments.

Fixpoint cons_branch_info_list (cl : list (list condition)) (sl : list statement) : res (list branch_info) :=
  match cl with
  | nil =>
    OK nil
  | hd :: tl =>
    do v2 <- cons_branch_info_list tl sl;
    OK ({| cond := hd; stmt := sl |} :: v2)
  end.

Definition trans_if_branch (id : identifier) (ib : if_branch) (fl : list field) : res (list branch_info) :=
  match ib with
  | If_Branch expr stmt_list =>
    do expr_list <- TransExpression.reorder_expression expr;
    do cond_list_list <- TransExpression.protocol_expression_list_to_condition_list id expr_list fl;
    cons_branch_info_list cond_list_list stmt_list
  end.

Fixpoint trans_if_branch_list (id : identifier) (ibl : list if_branch) (fl : list field) : res (list branch_info) :=
  match ibl with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_if_branch id hd fl;
    do v2 <- trans_if_branch_list id tl fl;
    OK (v1 ++ v2)
  end.

Definition trans_protocol_statement (id : identifier) (s : select_statement) (fl : list field) : res (list branch_info) :=
  match s with
  | As_If if_stmt =>
    match if_stmt with
    | If_Statement if_branch_list else_branch =>
      trans_if_branch_list id if_branch_list fl
    end
  | As_Simple simple_stmt =>
    OK ({| cond := nil; stmt := (simple_stmt :: nil) |} :: nil)
  end.

Fixpoint trans_protocol_statement_list (id : identifier) (sl : list select_statement) (fl : list field) : res (list branch_info) :=
  match sl with
  | nil =>
    OK nil
  | hd :: tl =>
    do v1 <- trans_protocol_statement id hd fl;
    do v2 <- trans_protocol_statement_list id tl fl;
    TransBranchInfo.multiply_branch_info v1 v2
  end.

Definition translate (id : identifier) (sl : list select_statement) (fl : list field) : res (list branch_info) :=
  trans_protocol_statement_list id sl fl.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.SpecLemmas.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.TermsAndIndicesFromOneLogInterface.
Require Import VerdiRaft.CurrentTermGtZeroInterface.

Section TermsAndIndicesFromOneLog.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.
  Context {ctgzi : current_term_gt_zero_interface}.

  Definition terms_and_indices_from_one_log_ind (net : network) : Prop :=
    terms_and_indices_from_one_log net /\ terms_and_indices_from_one_log_nw net.

  Lemma terms_and_indices_from_one_log_ind_init :
    raft_net_invariant_init terms_and_indices_from_one_log_ind.
  Proof using.
    split.
    - unfold terms_and_indices_from_one_log, terms_and_indices_from_one. simpl. contradiction.
    - unfold terms_and_indices_from_one_log_nw, terms_and_indices_from_one. simpl. contradiction.
  Qed.

  Lemma taifol_no_append_entries :
    forall ps' net ms p t leaderId prevLogIndex prevLogTerm entries leaderCommit h,
      (forall (p : packet), In p ps' -> In p (nwPackets net) \/ In p (send_packets h ms)) ->
      (forall m, In m ms -> ~ is_append_entries (snd m)) ->
      In p ps' ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm entries leaderCommit ->
      terms_and_indices_from_one_log_nw net ->
      terms_and_indices_from_one entries.
  Proof using.
    intros. find_apply_hyp_hyp. break_or_hyp; eauto. unfold send_packets in *. do_in_map.
    find_apply_hyp_hyp. unfold not in *. find_false.
    subst. simpl in *. repeat find_rewrite. eauto 10.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_client_request :
    raft_net_invariant_client_request terms_and_indices_from_one_log_ind.
  Proof using ctgzi.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
      find_apply_lem_hyp handleClientRequest_log. intuition.
      + repeat find_rewrite. auto.
      + break_exists. intuition.
        unfold terms_and_indices_from_one_log, terms_and_indices_from_one in *.
        intros. repeat find_rewrite. simpl in *. break_or_hyp.
        * intuition. find_apply_lem_hyp current_term_gt_zero_invariant. find_rewrite.
          eapply_prop current_term_gt_zero. congruence.
        * eauto.
    - eapply taifol_no_append_entries; pose handleClientRequest_no_append_entries; eauto.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_timeout :
    raft_net_invariant_timeout terms_and_indices_from_one_log_ind.
  Proof using.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
      find_apply_lem_hyp handleTimeout_log_same. find_rewrite. auto.
    - eapply taifol_no_append_entries; pose handleTimeout_packets; eauto.
  Qed.

  Lemma terms_and_indices_from_one_app :
    forall xs ys,
      terms_and_indices_from_one xs ->
      terms_and_indices_from_one ys ->
      terms_and_indices_from_one (xs ++ ys).
  Proof using.
    induction xs.
    - auto.
    - unfold terms_and_indices_from_one in *. simpl. intros. break_or_hyp; eauto.
  Qed.

  Lemma terms_and_indices_from_one_In :
    forall (xs ys : list entry),
      (forall x, In x xs -> In x ys) ->
      terms_and_indices_from_one ys ->
      terms_and_indices_from_one xs.
  Proof using.
    unfold terms_and_indices_from_one. eauto.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_append_entries :
    raft_net_invariant_append_entries terms_and_indices_from_one_log_ind.
  Proof using.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
      find_apply_lem_hyp handleAppendEntries_log. intuition.
      + find_rewrite. auto.
      + subst. unfold terms_and_indices_from_one_log_nw in *. eauto.
      + break_exists. intuition. subst. find_rewrite. apply terms_and_indices_from_one_app.
        * eauto.
        * eapply terms_and_indices_from_one_In; [eapply removeAfterIndex_in | eauto].
    - unfold terms_and_indices_from_one_log_nw in *. find_apply_hyp_hyp. intuition; eauto.
      find_apply_lem_hyp handleAppendEntries_not_append_entries.
      exfalso. apply H. repeat eexists. subst. eauto.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_append_entries_reply :
    raft_net_invariant_append_entries_reply terms_and_indices_from_one_log_ind.
  Proof using.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
      find_apply_lem_hyp handleAppendEntriesReply_log. find_rewrite. auto.
    - find_apply_hyp_hyp. intuition; eauto. do_in_map.
      find_apply_lem_hyp handleAppendEntriesReply_packets; eauto. subst. contradiction.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_request_vote :
    raft_net_invariant_request_vote terms_and_indices_from_one_log_ind.
  Proof using.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
      find_apply_lem_hyp handleRequestVote_log. find_rewrite. auto.
    - find_apply_hyp_hyp. intuition; eauto. find_apply_lem_hyp handleRequestVote_no_append_entries.
      unfold not in *. find_false. repeat eexists. subst. eauto.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_request_vote_reply :
    raft_net_invariant_request_vote_reply terms_and_indices_from_one_log_ind.
  Proof using.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_higher_order_rewrite. update_destruct; rewrite_update; auto.
      find_apply_lem_hyp handleRequestVoteReply_log. subst. find_rewrite. auto.
    - eauto.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_do_leader :
    raft_net_invariant_do_leader terms_and_indices_from_one_log_ind.
  Proof using.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
      find_apply_lem_hyp doLeader_log. find_rewrite. auto.
    - find_apply_hyp_hyp. intuition; eauto.
      unfold doLeader in *. repeat break_match; tuple_inversion; subst; try contradiction.
      repeat do_in_map. unfold replicaMessage in *. subst. simpl in *. find_inversion.
      eapply terms_and_indices_from_one_In. apply findGtIndex_in. auto.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_do_generic_server :
    raft_net_invariant_do_generic_server terms_and_indices_from_one_log_ind.
  Proof using.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
      find_apply_lem_hyp doGenericServer_log. find_rewrite. auto.
    - find_apply_lem_hyp doGenericServer_packets. find_apply_hyp_hyp. subst. intuition; eauto.
      do_in_map. contradiction.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_state_same_packet_subset :
    raft_net_invariant_state_same_packet_subset terms_and_indices_from_one_log_ind.
  Proof using.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_reverse_higher_order_rewrite. auto.
    - eauto.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_reboot :
    raft_net_invariant_reboot terms_and_indices_from_one_log_ind.
  Proof using.
    red. unfold terms_and_indices_from_one_log_ind. split; red; simpl in *; intuition.
    - find_higher_order_rewrite. update_destruct; subst; rewrite_update; auto.
      unfold reboot. eauto.
    - find_reverse_rewrite. eauto.
  Qed.

  Lemma terms_and_indices_from_one_log_ind_invariant :
    forall net,
      raft_intermediate_reachable net ->
      terms_and_indices_from_one_log_ind net.
  Proof using ctgzi.
    intros.
    apply raft_net_invariant; auto.
    - apply terms_and_indices_from_one_log_ind_init.
    - apply terms_and_indices_from_one_log_ind_client_request.
    - apply terms_and_indices_from_one_log_ind_timeout.
    - apply terms_and_indices_from_one_log_ind_append_entries.
    - apply terms_and_indices_from_one_log_ind_append_entries_reply.
    - apply terms_and_indices_from_one_log_ind_request_vote.
    - apply terms_and_indices_from_one_log_ind_request_vote_reply.
    - apply terms_and_indices_from_one_log_ind_do_leader.
    - apply terms_and_indices_from_one_log_ind_do_generic_server.
    - apply terms_and_indices_from_one_log_ind_state_same_packet_subset.
    - apply terms_and_indices_from_one_log_ind_reboot.
  Qed.

  Instance taifoli : terms_and_indices_from_one_log_interface.
  Proof.
    split.
    - apply terms_and_indices_from_one_log_ind_invariant.
    - apply terms_and_indices_from_one_log_ind_invariant.
  Qed.
End TermsAndIndicesFromOneLog.


From Coq Require Import Strings.String Strings.Ascii.

From Equations Require Import Equations.

From stdpp Require Import base finite gmap mapset listset_nodup numbers.

From MatchingLogic Require Import Syntax DerivedOperators_Syntax ProofSystem.

From MatchingLogicProver Require Import Named.

Module MetaMath.

  Inductive IncludeStmt := include_stmt (s : string).

  Inductive MathSymbol := ms (s : string).
  Inductive Constant := constant (ms : MathSymbol).
  Inductive ConstantStmt := constant_stmt (cs : list Constant).
  Inductive Variabl := variable (s : string).
  Inductive VariableStmt := vs (lv : list Variabl).
  Inductive DisjointStmt := ds (lv : list Variabl).
  Inductive TypeCode := tc (c : Constant).

  Inductive Label := lbl (s : string).

  Inductive FloatingStmt := fs (l : Label) (tc : TypeCode) (var : Variabl).
  Inductive EssentialStmt := es (l : Label) (tc : TypeCode) (lms : list MathSymbol).

  Inductive HypothesisStmt :=
  | hs_floating (fs : FloatingStmt)
  | hs_essential (es : EssentialStmt)
  .

  Inductive AxiomStmt := axs (l : Label) (tc : TypeCode) (lms : list MathSymbol).

  Inductive MMProof := pf (ll : list Label).

  Inductive ProvableStmt := ps (l : Label) (tc : TypeCode) (lms : list MathSymbol) (pf : MMProof).

  Inductive AssertStmt :=
  | as_axiom (axs : AxiomStmt)
  | as_provable (ps : ProvableStmt)
  .

  Inductive Stmt :=
  | stmt_block (ls : list Stmt)
  | stmt_variable_stmt (vs : VariableStmt)
  | stmt_disj_stmt (ds : DisjointStmt)
  | stmt_hyp_stmt (hs : HypothesisStmt)
  | stmt_assert_stmt (ass : AssertStmt).

  Inductive OutermostScopeStmt :=
  | oss_inc (incs : IncludeStmt)
  | oss_cs (cs : ConstantStmt)
  | oss_s (st : Stmt)
  .

  Definition Database := list OutermostScopeStmt.

  (* Concrete syntax printing. *)

  Definition IncludeStmt_toString (x : IncludeStmt) :=
    match x with
    | include_stmt s => append "$[ " (append s " $]")
    end.

  Definition MathSymbol_toString (x : MathSymbol) :=
    match x with
    | ms s => s
    end.

  Definition Constant_toString (x : Constant) :=
    match x with
    | constant s => MathSymbol_toString s
    end.

  Definition appendWith between x y :=
    append x (append between y).

  Definition ConstantStmt_toString (x : ConstantStmt) : string :=
    match x with
    | constant_stmt cs => append "$c " (append (foldr (appendWith " "%string) ""%string (map Constant_toString cs)) " $.")
    end.

  Definition Variabl_toString (x : Variabl) :=
    match x with
    | variable s => s
    end.

  Definition VariableStmt_toString (x : VariableStmt) : string :=
    match x with
    | vs lv => append "$v " (append (foldr (appendWith " "%string) ""%string (map Variabl_toString lv)) " $.")
    end.

  Definition DisjointStmt_toString (x : DisjointStmt) : string :=
    match x with
    | ds lv => append "$d " (append (foldr (appendWith " "%string) ""%string (map Variabl_toString lv)) " $.")
    end.

  Definition TypeCode_toString (x : TypeCode) : string :=
    match x with
    | tc c => Constant_toString c
    end.

  Definition Label_toString (x : Label) : string :=
    match x with
    | lbl s => s
    end.

  Definition FloatingStmt_toString (x : FloatingStmt) : string :=
    match x with
    | fs l t var => append
                      (Label_toString l)
                      (append
                         " $f "
                         (append
                            (appendWith " " (TypeCode_toString t) (Variabl_toString var))
                            " $."
                         )
                      )
    end.

    Definition EssentialStmt_toString (x : EssentialStmt) : string :=
    match x with
    | es l t lms => append
                      (Label_toString l)
                      (append
                         " $e "
                         (append
                            (appendWith " "
                               (TypeCode_toString t)
                               (foldr (appendWith " "%string) ""%string (map MathSymbol_toString lms))
                            )
                            " $."
                         )
                      )
    end.

    Definition HypothesisStmt_toString (x : HypothesisStmt) : string :=
      match x with
      | hs_floating f => FloatingStmt_toString f
      | hs_essential e => EssentialStmt_toString e
      end.

    Definition AxiomStmt_toString (x : AxiomStmt) : string :=
    match x with
    | axs l t lms => append
                      (Label_toString l)
                      (append
                         " $a "
                         (append
                            (appendWith " "
                               (TypeCode_toString t)
                               (foldr (appendWith " "%string) ""%string (map MathSymbol_toString lms))
                            )
                            " $."
                         )
                      )
    end.

    Definition MMProof_toString (x : MMProof) : string :=
      match x with
      | pf ll =>  foldr (appendWith " "%string) ""%string (map Label_toString ll)
      end.

    Definition ProvableStmt_toString (x : ProvableStmt) : string :=
      match x with
      | ps l t lms p
        => append
             (Label_toString l)
             (append
                " $p "
                (append
                   (append
                      (append (TypeCode_toString t) " ")
                      (foldr (appendWith " "%string) ""%string (map MathSymbol_toString lms))
                   )
                   (append " $= " (append (MMProof_toString p)  " $."))
                )
             )
      end.

    Definition AssertStmt_toString (x : AssertStmt) : string :=
      match x with
      | as_axiom astmt => AxiomStmt_toString astmt
      | as_provable p => ProvableStmt_toString p
      end.

    Fixpoint Stmt_toString (x : Stmt) : string :=
      match x with
      | stmt_block l
        => append "${ "
                  (append
                     (foldr (appendWith " "%string) ""%string (map Stmt_toString l))
                     " $}")
      | stmt_variable_stmt v => VariableStmt_toString v
      | stmt_disj_stmt d => DisjointStmt_toString d
      | stmt_hyp_stmt h => HypothesisStmt_toString h
      | stmt_assert_stmt astmt => AssertStmt_toString astmt
      end.

    Definition OutermostScopeStmt_toString (x : OutermostScopeStmt) : string :=
      match x with
      | oss_inc i => IncludeStmt_toString i
      | oss_cs c => ConstantStmt_toString c
      | oss_s s => Stmt_toString s
      end.

    Definition Database_toString (x : Database) : string :=
      foldr (appendWith "
"%string) "
"%string (map OutermostScopeStmt_toString x).

    Fixpoint Private_MathSymbol_from_string (s : string) : string :=
      match s with
      | EmptyString => ""
      | String v s' =>
        let n := nat_of_ascii v in
        let rest := (Private_MathSymbol_from_string s') in
        if decide (v = "$"%char) then
          "\DLR" ++ rest
        else
          if (decide (v = "\"%char)) then
            "\BSP" ++ rest
          else
            if (decide (v = " "%char)) then
              "\SPC" ++ rest
            else
              if (n <? 33) || (126 <? n)
              then "$$$GENERATE_SYNTAX_ERROR$$$" (* TODO metamath can't handle characters in this range *)
              else
                String v rest
      end.

    (*Compute (Private_MathSymbol_from_string "Ah$oj sve\te").*)

    Definition MathSymbol_from_string (s : string) : MathSymbol :=
      ms (Private_MathSymbol_from_string s).

End MetaMath.

Import MetaMath.
Section gen.
  Context
    {signature : Signature}
    {symbols_countable : Countable symbols}
    (symbolPrinter : symbols -> string)
    (evarPrinter : @evar variables -> string)
    (svarPrinter : @svar variables -> string)
  .

  Definition something (x : evar) := evarPrinter x.

  Definition constantForSymbol (s : symbols) : OutermostScopeStmt :=
    oss_cs (constant_stmt [constant (ms (symbolPrinter s))]).

  Definition axiomForSymbol (s : symbols) : OutermostScopeStmt :=
    oss_s (stmt_assert_stmt (as_axiom (axs
                                         (lbl (symbolPrinter s ++ "-is-pattern"))
                                         (tc (constant (ms "#Pattern")))
                                         [(ms (symbolPrinter s))]
          ))).

  Definition constantAndAxiomForSymbol (s : symbols) : Database :=
    [constantForSymbol s; axiomForSymbol s].

  Definition SymSet := listset_nodup symbols.
  Definition NEvarSet := listset_nodup evar.
  Definition NSvarSet := listset_nodup svar.

  Fixpoint symbols_of (p : NamedPattern) : SymSet :=
    match p with
    | npatt_bott | npatt_evar _ | npatt_svar _ => ∅
    | npatt_sym s => {[ s ]}
    | npatt_imp p1 p2 => symbols_of p1 ∪ symbols_of p2
    | npatt_app p1 p2 => symbols_of p1 ∪ symbols_of p2
    | npatt_exists _ p' => symbols_of p'
    | npatt_mu _ p' => symbols_of p'
    end.

  Fixpoint nevars_of (p : NamedPattern) : NEvarSet :=
    match p with
    | npatt_bott | npatt_svar _ | npatt_sym _ => ∅
    | npatt_evar x => {[x]}
    | npatt_imp p1 p2 => nevars_of p1 ∪ nevars_of p2
    | npatt_app p1 p2 => nevars_of p1 ∪ nevars_of p2
    | npatt_exists x p' => {[x]} ∪ nevars_of p'
    | npatt_mu _ p' => nevars_of p'
    end.

  Fixpoint nsvars_of (p : NamedPattern) : NSvarSet :=
    match p with
    | npatt_bott | npatt_evar _ | npatt_sym _ => ∅
    | npatt_svar X => {[X]}
    | npatt_imp p1 p2 => nsvars_of p1 ∪ nsvars_of p2
    | npatt_app p1 p2 => nsvars_of p1 ∪ nsvars_of p2
    | npatt_exists _ p' => nsvars_of p'
    | npatt_mu X p' => {[X]} ∪ nsvars_of p'
    end.

  Definition printEvar (x : evar) : string := "evar-" ++ (evarPrinter x).
  Definition isElementVar (x : evar) : Label := lbl ((printEvar x) ++ "-is-element-var").

  Definition printSvar (X : svar) : string := "svar-" ++ (svarPrinter X).
  Definition isSetVar (X : svar) : Label := lbl ((printSvar X) ++ "-is-set-var").

  Definition frameAsElementVariable (x : evar) : OutermostScopeStmt :=
    oss_s (stmt_hyp_stmt (hs_floating
                            (fs
                               (isElementVar x)
                               (tc (constant (ms "#ElementVariable")))
                               (variable (printEvar x))))).

  Definition frameAsSetVariable (X : svar) : OutermostScopeStmt :=
    oss_s (stmt_hyp_stmt (hs_floating
                            (fs
                               (isSetVar X)
                               (tc (constant (ms "#SetVariable")))
                               (variable (printSvar X))))).

  Definition dependenciesForPattern (p : NamedPattern) : Database :=
    let sms := listset_nodup_car (symbols_of p) in
    let nevs := listset_nodup_car (nevars_of p) in
    let nsvs := listset_nodup_car (nsvars_of p) in
    (concat (map constantAndAxiomForSymbol sms))
      ++ (if decide (0 < length nevs) then
            [(oss_s (stmt_variable_stmt (vs (map (variable ∘ printEvar) nevs))))]
          else []
         )
      ++ (if decide (0 < length nsvs) then
            [(oss_s (stmt_variable_stmt (vs (map (variable ∘ printSvar) nsvs))))]
          else []
         )
      ++ (if decide (1 < length nevs) then
            [(oss_s (stmt_disj_stmt (ds (map (variable ∘ printEvar) nevs))))]
          else []
         )
      ++ (if decide (1 < length nsvs) then
            [(oss_s (stmt_disj_stmt (ds (map (variable ∘ printSvar) nsvs))))]
          else []
         )
      ++ (map frameAsElementVariable nevs)
      ++ (map frameAsSetVariable nsvs)
  .

  Fixpoint pattern2mm (p : NamedPattern) : list MathSymbol :=
    match p with
    | npatt_sym s => [ms (symbolPrinter s)] (* TODO: use printSymbol *)
    | npatt_evar x => [ms (printEvar x)]
    | npatt_svar X => [ms (printSvar X)]
    | npatt_imp p1 p2 =>
      let ms1 := pattern2mm p1 in
      let ms2 := pattern2mm p2 in
      [(ms "("); (ms "\imp")] ++ ms1 ++ ms2 ++ [ (ms ")")]
    | npatt_app p1 p2 =>
      let ms1 := pattern2mm p1 in
      let ms2 := pattern2mm p2 in
      [(ms "("); (ms "\app")] ++ ms1 ++ ms2 ++ [ (ms ")")]
    | npatt_bott => [(ms "\bot")]
    | npatt_exists x p' =>
      let msx := [ms (printEvar x)] in
      let msp' := pattern2mm p' in
      [(ms "("); (ms "\exists")] ++ msx ++ msp' ++ [(ms ")")]
    | npatt_mu X p' =>
      let msX := [ms (printSvar X)] in
      let msp' := pattern2mm p' in
      [(ms "("); (ms "\exists")] ++ msX ++ msp' ++ [(ms ")")]
    end.

  Fixpoint pattern2proof (p : NamedPattern) : list Label :=
    match p with
    | npatt_sym s => [(lbl (symbolPrinter s ++ "-is-pattern"))]
    | npatt_evar x => [(isElementVar x); (lbl "element-var-is-var"); (lbl "var-is-pattern")]
    | npatt_svar X => [(isSetVar X); (lbl "set-var-is-var"); (lbl "var-is-pattern")]
    | npatt_imp p1 p2 =>
      let ms1 := pattern2proof p1 in
      let ms2 := pattern2proof p2 in
      ms1 ++ ms2 ++ [(lbl "imp-is-pattern")]
    | npatt_app p1 p2 =>
      let ms1 := pattern2proof p1 in
      let ms2 := pattern2proof p2 in
      ms1 ++ ms2 ++ [(lbl "app-is-pattern")]
    | npatt_bott => [(lbl "bot-is-pattern")]
    | npatt_exists x p' =>
      let lsx := [(isElementVar x)] in
      let lsp' := pattern2proof p' in
      lsp' ++ lsx ++ [(lbl "exists-is-pattern")]
    | npatt_mu X p' =>
      let lsX := [(isSetVar X)] in
      let lsp' := pattern2proof p' in
      lsp' ++ lsX ++ [(lbl "mu-is-pattern")]
    end.

  Fixpoint proof_size' Γ (ϕ : Pattern) (pf : ML_proof_system Γ ϕ) : nat :=
    match pf with
    | hypothesis _ _ _ _ => 1
    | P1 _ _ _ _ _ => 1
    | P2 _ _ _ _ _ _ _ => 1
    | P3 _ _ _ => 1
    | Modus_ponens _ _ _ pf1 pf2 => 1 + proof_size' _ _ pf1 + proof_size' _ _ pf2
    | Ex_quan _ _ _ _ => 1
    | Ex_gen _ _ _ _ _ _ pf' _ => 1 + proof_size' _ _ pf'
    | Prop_bott_left _ _ _ => 1
    | Prop_bott_right _ _ _ => 1
    | Prop_disj_left _ _ _ _ _ _ _ => 1
    | Prop_disj_right _ _ _ _ _ _ _ => 1
    | Prop_ex_left _ _ _ _ _ => 1
    | Prop_ex_right _ _ _ _ _ => 1
    | Framing_left _ _ _ _ _ pf' => 1 + proof_size' _ _ pf'
    | Framing_right _ _ _ _ _ pf' => 1 + proof_size' _ _ pf'
    | Svar_subst _ _ _ _ _ _ pf' => 1 + proof_size' _ _ pf'
    | Pre_fixp _ _ _ => 1
    | Knaster_tarski _ _ _ _ pf' => 1 + proof_size' _ _ pf'
    | Existence _ => 1
    | Singleton_ctx _ _ _ _ _ _ => 1
    end.

  Definition proof_size'' Γ (x : {ϕ : Pattern & ML_proof_system Γ ϕ}) :=
    proof_size' Γ (projT1 x) (projT2 x).

  Definition proof2proof'_stack Γ := list ({ϕ : Pattern & ML_proof_system Γ ϕ} + Label).

  Definition proof2proof'_stack_size Γ (s : proof2proof'_stack Γ)
    := (fold_right
          plus
          0
          (map
             (fun it =>
                match it with
                | inl p => 2 * proof_size'' Γ p
                | inr _ => 1
                end
             )
             s
          )
       ).

  (* (exists x, x) -> exists x, (exists y, y)  *)
  (* (exists, 0) -> (exists, exists, 0)  *)
  (* (exists x, x) -> (phi -> (exists y, y)) *)

  Print Ex_quan.

 Equations? proof2proof'
            Γ
            (acc : list Label)
            (pfs : list ({ϕ : Pattern & ML_proof_system Γ ϕ} + Label))
    : list Label
    by wf (proof2proof'_stack_size Γ pfs) lt :=

    proof2proof' Γ acc [] := reverse acc ;

    proof2proof' Γ acc ((inr l)::pfs')
      := proof2proof' Γ (l::acc) pfs' ;

    proof2proof' Γ acc ((inl (existT ϕ (P1 _ p q _ _)))::pfs')
      := proof2proof'
           Γ
           ([lbl "proof-rule-prop-1"]
              ++ (reverse (pattern2proof (to_NamedPattern2 q)))
              ++ (reverse (pattern2proof (to_NamedPattern2 p)))
              ++ acc)
           pfs' ;

    proof2proof' Γ acc ((inl (existT ϕ (P2 _ p q r _ _ _)))::pfs')
      := proof2proof'
           Γ
           ([lbl "proof-rule-prop-2"]
              ++ (reverse (pattern2proof (to_NamedPattern2 r)))
              ++ (reverse (pattern2proof (to_NamedPattern2 q)))
              ++ (reverse (pattern2proof (to_NamedPattern2 p)))
              ++ acc)
           pfs' ;

    proof2proof' Γ acc ((inl (existT ϕ (P3 _ p _)))::pfs')
      := proof2proof'
           Γ
           ([lbl "proof-rule-prop-3"]
              ++ (reverse (pattern2proof (to_NamedPattern2 p)))
              ++ acc)
           pfs' ;

    proof2proof' Γ acc ((inl (existT _ (Modus_ponens _ p q pfp pfpiq)))::pfs')
      := proof2proof'
           Γ
           ((reverse (pattern2proof (to_NamedPattern2 q)))
              ++ (reverse (pattern2proof (to_NamedPattern2 p)))
              ++ acc)
           ((inl (existT _ pfpiq))::(inl (existT _ pfp))::(inr (lbl "proof-rule-mp"))::pfs') ;

    proof2proof' Γ acc ((inl (existT ϕ (Ex_quan _ p y _)))::pfs')
      := proof2proof'
           Γ
           ([lbl "proof-rule-exists"]
              ++ (reverse (pattern2proof (to_NamedPattern2 (instantiate p (patt_free_evar y)))))
              ++ (reverse (pattern2proof (to_NamedPattern2 p)))
              ++ acc)
           pfs' ;

    proof2proof' Γ prefix ((inl _)::_) := []
  .
  Proof.
    - unfold proof2proof'_stack_size. simpl. lia.
    - unfold proof2proof'_stack_size. simpl. lia.
    - unfold proof2proof'_stack_size. simpl. lia.
    - unfold proof2proof'_stack_size.
      rewrite !map_cons. simpl.
      unfold proof_size''. simpl.
      simpl.
      remember (proof_size' Γ (patt_imp p q) pfpiq) as A.
      remember (proof_size' Γ p pfp) as B.
      remember ((foldr Init.Nat.add 0
                       (map
                          (λ it : {ϕ : Pattern & ML_proof_system Γ ϕ} + Label,
                                  match it with
                                  | inl p0 => proof_size' Γ (projT1 p0) (projT2 p0) + (proof_size' Γ (projT1 p0) (projT2 p0) + 0)
                                  | inr _ => 1
                                  end) pfs'))) as C.
      lia.
    - unfold proof2proof'_stack_size. simpl. lia.
    - unfold proof2proof'_stack_size. simpl. lia.
  Defined.

  Definition proof2proof Γ (ϕ : Pattern) (pf : ML_proof_system Γ ϕ) : list Label :=
    proof2proof' Γ [] [(inl (existT ϕ pf))].

  (*
  Fixpoint proof2proof (Γ : Theory) (ϕ : Pattern) (pf : ML_proof_system Γ ϕ) : list Label :=
    match pf as _ return list Label with
    | P1 _ p q wfp wfq => pattern2proof p ++ pattern2proof q ++ [lbl "proof-rule-prop-1"]
    | P2 _ p q r wfp wfq wfr =>
      pattern2proof p ++ pattern2proof q ++ pattern2proof r ++ [lbl "proof-rule-prop-2"]
    | P3 _ p wfp => pattern2proof p ++ [lbl "proof-rule-prop-3"]
    | Modus_ponens _ p q wfp wfpiq pfp pfpiq =>
      (pattern2proof p)
        ++ (pattern2proof q)
        ++ (proof2proof Γ _ pfpiq)
        ++ (proof2proof Γ _ pfp)
        ++ [lbl "proof-rule-mp"]
    | _ => []
    end.
   *)

  Definition proof2database Γ (ϕ : Pattern) (proof : ML_proof_system Γ ϕ) : Database :=
    let named := to_NamedPattern2 ϕ in
    [oss_inc (include_stmt "mm/matching-logic.mm")] ++
    (dependenciesForPattern named)
      ++ [oss_s (stmt_assert_stmt (as_provable (ps
                                                  (lbl "the-proof")
                                                  (tc (constant (ms "|-")))
                                                  (pattern2mm named)
                                                  (pf (proof2proof Γ ϕ proof))
         )))].

End gen.


(******************************************************************************
September 2004
Authors: Jean-Yves Vion-dury and Pierre Geneves

jean-yves.vion-dury@xrce.xerox.com
WAM Research Project, INRIA Rhone-Alpes and Xerox Research Center Europe

pierre.geneves@inrialpes.fr
WAM Research Project, INRIA Rhone-Alpes

Please do not reuse or publish this code without explicit consent from authors.
*******************************************************************************)
Require Import setOrder.
Require Export XPath.
Require Import xnodes.
Require Import XPathInduction.
(* Require XPathBasicProp.*)
Require Import Mapping.
Require Import graphInt.
Require Export nat_basics.
Require Import XPequiv.

Require Import XPathGrammar.

(* ========================================================================================*)
(* This part defines all axioms of the theory in two mutually inductive definitions        *)
(*	this allows usefull inversions (see Inversion tactic)                              *)
(* ========================================================================================*)

Inductive Qualif : XPath -> Prop :=
    is_qualif : forall (p : XPath) (q : XQualif), Qualif (qualif p q).

Inductive Ple : XPath -> XPath -> Prop :=

  (* basics *)
  | p_void : forall p : XPath, Ple void p
  | p_top : Ple top top

  (* -------- step comparison ------------- *)

  | p_step :
      forall (a1 a2 : Axis) (n1 n2 : NodeTest),
      axis_le a1 a2 ->
      ntest_le a2 n1 n2 ->
      Ple (a1:::n1) (a2:::n2)

      (* ---- slash based rules ------ *)

| p_desc :
      forall (p1 p2 : XPath) (n2 : NodeTest) (q:XQualif),
      Ple p1 (descendant:::%node()) ->
      Ple p2 (qualif (descendant:::n2) q) ->
      Ple (p1/p2) (qualif (descendant:::n2) q)

      (* -------- relative-absolute absolute comparisons -------------------------- *)
  | p_abs:
	forall (p : XPath) (q1 q2:XQualif) (n2 : NodeTest),
	Qipl (path (descendant:::%node()/p)) q1 ->
	Ple p (qualif (descendant:::n2) q2)  ->
	Ple p ((qualif top q1)/(qualif (descendant:::n2) q2))
      (* ----------- *)
|  p_slash :
      forall p11 p12 p21 p22 : XPath,
      Ple (qualif p11 (#p12))   (qualif p21 (#p22)) ->
      Ple p12 p22 ->
      Ple (p11/p12) (p21/p22)

      (* ------- intersection rules -------- *)
  | p_inter_R:
      forall p1 p2 p : XPath,
      Ple p p1 ->
      Ple p p2 ->
      Ple p (inter p1 p2)
  | p_inter_L:
      forall p1 p2 p : XPath,
      Ple p1 p ->
      Ple (inter p1 p2) p

      (* ------- union rules -------- *)
  | p_union_L :
      forall p11 p12 p2 : XPath,
      Ple p11 p2 -> Ple p12 p2 -> Ple (union p11 p12) p2

  | p_union_R :
      forall p1 p21 p22 : XPath,
      Ple p1 p21 -> Ple p1 (union p21 p22)

      (* -------- qualif comparison ------------- *)
  | p_qual :
      forall p1 p2 : XPath,
      forall q1 q2 : XQualif,
      Ple p1 p2 -> Qipl q1 q2 -> Ple (qualif p1 q1) (qualif p2 q2)

with Qipl : XQualif -> XQualif -> Prop :=

  | q_leq (* e1 *) :
      forall p11 p12 p21 p22 : XPath,
      Ple p21 p11 -> Ple p12 p22 -> Qipl (leq p11 p12) (leq p21 p22)

  | q_not (* e2 *):
      forall q1 q2 : XQualif, Qipl q2 q1 -> Qipl (not q1) (not q2)

  | q_true (* e3a *) :
      forall q : XQualif, Qipl q _true

  | q_false (* e3b *) :
      forall q : XQualif, Qipl _false q

  | q_and_L (* e4 *) :
      forall q11 q12 q2 : XQualif,
      Qipl q11 q2 -> Qipl (q11 and q12) q2

  | q_and_R (* e5 *) :
      forall q1 q21 q22 : XQualif,
      Qipl q1 q21 -> Qipl q1 q22 ->
      Qipl q1 (q21 and q22)

  | q_or_R (* e6 *) :
      forall q1 q21 q22 : XQualif,
      Qipl q1 q21 ->
      Qipl q1 (q21 or q22)

  | q_or_L (* e7 *) :
      forall q11 q12 q2 : XQualif,
      Qipl q11 q2 -> Qipl q12 q2 ->
      Qipl (q11 or q12) q2

(*
  | f2 :
      forall (p1 p2 : XPath) (q1 q2 : XQualif),
      Qipl (leq p1 void) (leq p2 void) ->
      Qipl (leq (qualif p1 q1) void) (leq (qualif p2 q2) void)
  | f3 :
      forall (p1 p2 : XPath) (q1 q2 : XQualif),
      Ple p1 p2 ->
      Qipl (not q1) (not q2) ->
      Qipl (leq (qualif p1 q1) void) (leq (qualif p2 q2) void)
*)
  | q_child_desc (* f4 *) :
      forall nt : NodeTest,
	(ntest_le descendant nt _element) ->
      Qipl (leq (step child _any) void) (leq (step descendant nt) void)

      (* the corresponding propositional equality *)
with Peq : XPath -> XPath -> Prop :=

  |  p_eq : forall p1 p2 : XPath, Ple p1 p2 -> Ple p2 p1 -> Peq p1 p2
.

Notation "p1 ≤ p2" := (Ple p1 p2) (at level 90, no associativity) : Xrel.
Notation "q1 ⇨ q2" := (Qipl q1 q2) (at level 90, no associativity) : Xrel.
Notation "p1 ≈ p2" := (Peq p1 p2) (at level 90, no associativity) : Xrel.

Open Scope Xp.
Open Scope Xrel.

 (*======= generic usage of equiv ======= *)
Axiom p_gene_L  :
      forall p1 p3:XPath,
      (exists p2:XPath,   (p1 ⇾ p2)    /\   ( p2 ≤ p3) ) ->
      p1 ≤ p3
      .

Axiom p_gene_R  :
      forall p1 p3:XPath,
      (exists p2:XPath,   (p3 ⇾ p2)   /\    (p1 ≤ p2) ) ->
      p1 ≤ p3
	.

Axiom q_gene_L :
      forall q1 q3:XQualif,
      (exists q2:XQualif, (q1 ⇐⇒ q2)   /\   (q2 ⇨ q3) ) ->
      q1 ⇨ q3
	.

Axiom q_gene_R :
      forall q1 q3:XQualif,
      (exists q2:XQualif,  (q3 ⇐⇒ q2)  /\  (q1 ⇨ q2) ) ->
      q1 ⇨ q3
	.

Definition ple_reflexive (p1 p2:XPath):Prop :=     p1=p2 -> p1 ≤ p2.
Definition qipl_reflexive (q1 q2:XQualif):Prop :=  q1=q2 -> q1 ⇨ q2.

Ltac t1 :=
   match goal with  IHn1:_ |- _ =>
   simpl in |- *;
     intro p2; case p2; simpl in |- *;
     [
	   intro; apply IHn1;auto with arith
	 | intro; apply IHn1; auto with arith
	 | intros; unfold ple_reflexive in |- *; intros; discriminate
	 | intros; unfold ple_reflexive in |- *; intros; discriminate
	 | intros; unfold ple_reflexive in |- *; intros; discriminate
	 | intros; unfold ple_reflexive in |- *; intros; discriminate
	 | intros; unfold ple_reflexive in |- *; intros; discriminate
	 ]
     end.

Ltac redMax H :=
  LeS;
  rewrite max_idem in H;
  rewrite max_idem;
      apply H
  ||  (match goal with
      H:max ?a ?b <= ?n |- ?a <= ?n  => eapply max_le_L
      |  H:max ?a ?b <= ?n |- ?b  <= ?n  => eapply max_le_R
     end;apply H)
  .

Lemma Ple_Qipl_reflexive:
    (forall p1 p2:XPath, (ple_reflexive p1 p2)) /\
    (forall q1 q2:XQualif, (qipl_reflexive q1 q2)).

apply HGen22.
induction n.
 (* base cases *)
 simpl in |- *.
   unfold Hyp22 in |- *.
   split.
  intros p1 p2; case p1; case p2; intros;
   match goal with
   | H:(_ <= 0) |- _ => inversion H
   end.
   unfold ple_reflexive in |- *; intros; constructor.
   unfold ple_reflexive in |- *; intros; discriminate.
   unfold ple_reflexive in |- *; intros; discriminate.
   unfold ple_reflexive in |- *; intros; constructor.

  intros q1 q2; case q1; case q2; intros;
   match goal with
   | H:(_ <= 0) |- _ => inversion H
   end.
   unfold qipl_reflexive in |- *; intros; constructor.
   unfold qipl_reflexive in |- *; intros; discriminate.
   unfold qipl_reflexive in |- *; intros; discriminate.
   unfold qipl_reflexive in |- *; intros; constructor.

(* Inductive step *)
unfold Hyp22 in IHn |- *.
   elim IHn; intros IHn1 IHn2.
   clear IHn.
   split.
(* ---- path *)
  intro p1; case p1.
   (* void p2 *)
   t1.
   (* top p2 *)
   t1.
   (* union p2 *)
   unfold ple_reflexive in |- *.
   intros.
   rewrite <- H0.
   rewrite <- H0 in H.
   simpl in H.
   apply p_union_L; [ apply p_union_R | apply p_gene_R;exists (union x0 x);split;[apply red_gen;rewrite Pequiv_symmetric | apply p_union_R ] ].
    (* Ple x x *)
    apply IHn1;[redMax H | reflexivity].
    constructor.
    (* Ple x0 x0 *)
    apply IHn1;[redMax H | reflexivity].
   (* inter p2 *)
   unfold ple_reflexive in |- *.
   intros.
   rewrite <- H0.
   rewrite <- H0 in H.
   simpl in H.
  apply p_inter_R;[apply p_inter_L | apply p_gene_L;exists (inter x0 x);split;[apply red_gen;rewrite Pequiv_symmetric | apply p_inter_L] ].

  apply IHn1;[redMax H | reflexivity].
  constructor.
  apply IHn1;[redMax H | reflexivity].

 (* slash p2 *)
  unfold ple_reflexive in |- *.
   intros.
   rewrite <- H0.
   rewrite <- H0 in H.
   simpl in H.
  apply p_slash.
  constructor.
  apply IHn1;[redMax H | reflexivity].
  unfold path;constructor;constructor.
  apply IHn1;[redMax H | reflexivity].
  constructor.
  apply IHn1;[redMax H | reflexivity].

   (* qualif p2 *)
 unfold ple_reflexive in |- *.
   intros.
  rewrite <- H0.
   rewrite <- H0 in H.
  simpl in H.
  apply p_qual;[apply IHn1 | apply IHn2];redMax H || reflexivity.

   (* step p2 *)
unfold ple_reflexive in |- *.
   intros.
  rewrite <- H0.
   rewrite <- H0 in H.
  simpl in H.
 constructor.
   case a;simpl;trivial.
   case n0;simpl;trivial.
  (* ------ qualifiers *)
  intros q1 q2;case q1;unfold qipl_reflexive; intros;inversion H0;rewrite <- H0 in H;clear H0 H1;simpl in H.
 (* not *)
 constructor;
 apply IHn2;[redMax H | reflexivity].
 (* and *)
  apply q_and_R;[apply q_and_L | apply q_gene_L].
  apply IHn2;[redMax H | reflexivity].
 exists (x0 and x);split;constructor.
  apply IHn2;[redMax H | reflexivity].
(* or *)
apply q_or_L;[apply q_or_R | apply q_gene_R].
  apply IHn2; [redMax H | reflexivity].
 exists (x0 or x);split;[constructor | apply q_or_R ].
  apply IHn2; [redMax H | reflexivity].

 (* leq *)
constructor.
   apply IHn1;[redMax H| reflexivity].
   apply IHn1;[redMax H| reflexivity].
(* _true *)
constructor.
 (* _false *)
constructor.
Qed.

Theorem Ple_reflexive: forall p:XPath, p ≤ p.
assert (H:= Ple_Qipl_reflexive).
elim H;intros H1 H2 p;apply H1.
reflexivity.
Qed.

Theorem Qipl_reflexive: forall q:XQualif, q ⇨ q.
assert (H:= Ple_Qipl_reflexive).
elim H;intros H1 H2 q;apply H2.
reflexivity.
Qed.

Conjecture Ple_transitive: forall p1 p2 p3:XPath, p1 ≤ p2  ->  p2 ≤ p3  ->  p1 ≤ p3.

(* I don't known if this proof has any value...seems too much regular *)
Lemma equiv_eq_sound:
    forall p1 p2:XPath,
    (p1 ⇽⇾ p2)  ->  p1 ≈ p2
    .
intros p1 p2 H.
inversion H;
match goal with
  |- ?a ≈ ?b =>
  split;[ apply p_gene_L | apply p_gene_R];
  exists b;(split;[apply red_gen;constructor | apply Ple_reflexive ]);trivial
end.
Qed.


Require Import Metalib.Metatheory.
Require Import Metalib.LibTactics.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Strings.String.
Require Import Lia.

Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.
Require Import Subtyping.Toplike.
Require Import Subtyping.Unisub.
Require Import Appsub.

Require Import Value.
Require Import Disjoint.
Require Import PrincipalTyping.
Require Import Consistent.
Require Import Typing.
Require Import Casting.
Require Import LocallyNameless.
Require Import Application.

(** * Definition *)

Inductive step : term -> term -> Prop :=
| St_Lit : forall n,
    step (Lit n) (Ann (Lit n) Int)
| St_Lam : forall e A B,
    step (Lam A e B) (Ann (Lam A e B) (Arr A B))
| St_Spl : forall p A A1 A2,
    pvalue p ->
    splitable A A1 A2 ->
    step (Ann p A) (Mrg (Ann p A1) (Ann p A2))
| St_App : forall f v e,
    value f -> value v ->
    papp f (Av v) e ->
    step (App f v) e
| St_Prj : forall l v e,
    value v ->
    papp v (Al l) e ->
    step (Prj v l) e
| St_Val : forall v v' A,
    value v ->
    casting v A v' ->
    step (Ann v A) v'
| St_Ann : forall e e' A,
    not (pvalue e) ->
    step e e' ->
    step (Ann e A) (Ann e' A)
| St_App_L : forall e1 e1' e2,
    lc e2 ->
    step e1 e1' ->
    step (App e1 e2) (App e1' e2)
| St_App_R : forall v e2 e2',
    value v ->
    step e2 e2' ->
    step (App v e2) (App v e2')
| St_Rcd : forall l e e',
    step e e' ->
    step (Fld l e) (Fld l e')
| St_Prj_L : forall e e' l,
    step e e' ->
    step (Prj e l) (Prj e' l)
| St_Mrg : forall e1 e1' e2 e2',
    step e1 e1' ->
    step e2 e2' ->
    step (Mrg e1 e2) (Mrg e1' e2')
| St_Mrg_L : forall e1 v e1',
    value v ->
    step e1 e1' ->
    step (Mrg e1 v) (Mrg e1' v)
| St_Mrg_R : forall v e2 e2',
    value v ->
    step e2 e2' ->
    step (Mrg v e2) (Mrg v e2').

Hint Constructors step : core.

Notation "e ⟾ e'" := (step e e') (at level 68).

(** * Value *)

Lemma value_no_step :
  forall v,
    value v -> forall e, ~ step v e.
Proof.
  introv Val.
  induction v; intros; eauto.
  - intros St.
    dependent destruction Val. dependent destruction St; eauto.
    + eapply IHv1; eauto.
    + eapply IHv1; eauto.
    + eapply IHv2; eauto.
  - dependent destruction Val.
    destruct H.
    + intros St. dependent destruction St; eauto.
    + intros St. dependent destruction St; eauto.
  - intros St.
    dependent destruction St.
    dependent destruction Val.
    pose proof (IHv Val e'). contradiction.
Qed.

Lemma step_lc :
  forall e e',
    lc e -> step e e' -> lc e'.
Proof.
  introv Lc St. gen e'.
  induction Lc; intros;
    try solve [dependent destruction St; eauto 3].
  - dependent destruction St. eapply Lc_Ann. eapply Lc_Lam; eauto.
  - Case "App".
    dependent destruction St; try solve [econstructor; eauto].
    pose proof (papp_lc_v e1 e2 e). eauto 3.
  - dependent destruction St; econstructor; eauto.
  - dependent destruction St.
    + econstructor; eapply Lc_Ann; eapply lc_pvalue; eauto.
    + eapply casting_lc; eauto.
    + econstructor. eauto.
  - dependent destruction St. econstructor. eauto.
  - Case "Prj".
    dependent destruction St; try solve [econstructor; eauto].
    pose proof (papp_lc_l e l e0). eauto 3.
Qed.

Lemma step_uvalue :
  forall u u',
    uvalue u -> step u u' -> uvalue u'.
Proof.
  introv Uv St. gen u'.
  induction Uv; intros.
  - dependent destruction St; eauto.
    eapply Uv_Ann. eapply step_lc; eauto.
  - dependent destruction St; eauto.
  - dependent destruction St; eauto.
Qed.

Hint Resolve step_uvalue : core.

(** * Determinism *)

Section determinism.

Ltac solver1 := try solve [match goal with
                           | [Val: value ?v, St: step ?v _ |- _] =>
                               (pose proof (value_no_step _ Val _ St); contradiction)
                           end].

Theorem determinism:
  forall e e1 e2 A,
    typing nil e Inf A ->
    step e e1 -> step e e2 -> e1 = e2.
Proof.
  introv Typ St1 St2. gen e2 A.
  dependent induction St1; intros.
  - dependent destruction St2; eauto.
  - dependent destruction St2; eauto.
  - dependent destruction St2; eauto.
    subst_splitable. reflexivity.
  - dependent destruction St2; solver1.
    dependent destruction Typ.
    pose proof (papp_determinism_v f v e e0).
    eapply uunisub_sound_appsub in H5; eauto.
  - dependent destruction St2; solver1.
    dependent destruction Typ.
    pose proof (papp_determinism_l v l e e0).
    eapply uunisub_sound_appsub in H3; eauto.
  - dependent destruction St2; eauto; solver1.
    dependent destruction Typ.
    dependent destruction Typ.
    eapply casting_determinism; eauto.
  - dependent destruction St2; eauto; solver1.
    f_equal. dependent destruction Typ.
    dependent destruction Typ; eauto.
  - dependent destruction St2; solver1.
    f_equal. dependent destruction Typ; eauto.
  - dependent destruction St2; solver1.
    f_equal. dependent destruction Typ; eauto.
  - dependent destruction St2; solver1.
    dependent destruction Typ;
      f_equal; eauto.
  - dependent destruction St2; solver1.
    dependent destruction Typ;
      f_equal; eauto.
  - dependent destruction St2; solver1.
    dependent destruction Typ;
      f_equal; eauto.
  - dependent destruction St2; solver1.
    dependent destruction Typ;
      f_equal; eauto.
  - dependent destruction St2; solver1.
    dependent destruction Typ;
      f_equal; eauto.
Qed.

End determinism.

(** * Consistent *)

Inductive step_or_value : term -> term -> Prop :=
| Sv_V : forall v, value v -> step_or_value v v
| Sv_S : forall e1 e2, step e1 e2 -> step_or_value e1 e2.

Hint Constructors step_or_value : core.

Lemma size_term_lg_z :
  forall e, size_term e > 0.
Proof.
  introv.
  dependent induction e; try solve [eauto | simpl; lia].
Qed.

Hint Resolve size_term_lg_z : core.

Lemma size_term_lg_z_any1 :
  forall e1 e2,
    size_term e1 < (size_term e2 + size_term e1).
Proof.
  introv.
  assert (size_term e2 > 0). eapply size_term_lg_z.
  lia.
Qed.

Lemma size_term_lg_z_any2 :
  forall e1 e2,
    size_term e1 < (size_term e1 + size_term e2).
Proof.
  introv.
  assert (size_term e2 > 0). eapply size_term_lg_z.
  lia.
Qed.

Hint Resolve size_term_lg_z_any1 : core.
Hint Resolve size_term_lg_z_any2 : core.

Section step_consistent.

Ltac solver1 := match goal with
                | [St: step (Ann (Lam _ _ _) _) _ |- _] => (dependent destruction St; eauto)
                end.

Ltac solver2 := match goal with
                | [St: step (Ann _ _) _ |- _] => (dependent destruction St; eauto)
                end.

Ltac solver3 := match goal with
                | [Val: value ?v, St: step ?v _ |- _] =>
                    (pose proof (value_no_step _ Val _ St); contradiction)
                end.

Ltac solver4 IHC IH :=
  eapply IHC; eauto; intros; match goal with
                             | St: step ?e ?e' |- _ => eapply (IH e e'); eauto; simpl; lia
                             end.

Lemma step_consistent :
  forall e1 e2 e1' e2' A B,
    uvalue e1 -> uvalue e2 ->
    typing nil e1 Inf A -> typing nil e2 Inf B ->
    consistent e1 e2 ->
    step_or_value e1 e1' -> step_or_value e2 e2' ->
    (forall e e' A, size_term e < (size_term e1 + size_term e2) ->
        typing nil e Inf A -> step e e' -> (exists C, typing nil e' Inf C /\ isosub C A)) ->
    consistent e1' e2'.
Proof.
  introv Uv1 Uv2 Typ1 Typ2 Con Sv1 Sv2 IH. gen A B e1' e2'.
  dependent induction Con; intros; eauto.
  - Case "Lam Lam".
    dependent destruction Sv1; dependent destruction Sv2; eauto; try solve [solver1].
    dependent destruction Typ1. dependent destruction Typ2.
    solver1. solver1. eapply Con_Mrg_L; eauto.
  - Case "Anno Anno".
    dependent destruction Sv1; dependent destruction Sv2; eauto; try solve [solver2].
    dependent destruction Typ1. dependent destruction Typ2.
    solver2.
    * solver2. eapply Con_Mrg_L; eauto.
    * solver2; try solve [solver3].
      dependent destruction Typ1.
      pose proof (casting_preservation e v' B0 A) as Cp1.
      dependent destruction Typ2.
      pose proof (casting_preservation e v'0 B A0) as Cp2.
      destruct Cp1; destruct Cp2; eauto. destruct_conjs.
      eapply casting_consistent; eauto.
    * solver2; try solve [solver3].
      dependent destruction Typ1. dependent destruction Typ2.
      assert (e' = e'0). eapply determinism; eauto. subst. econstructor; eauto.
      eapply step_lc; eauto.
  - Case "Rcd Rcd".
    dependent destruction Uv1. dependent destruction Uv2.
    dependent destruction Typ1. dependent destruction Typ2.
    dependent destruction Sv1; dependent destruction Sv2; eauto.
    + match goal with
      | St: step _ _, Val: value (Fld _ _) |- _ => dependent destruction St; dependent destruction Val
      end.
      eapply Con_Rcd. eapply IHCon; eauto 3. intros. eapply (IH e e'0); eauto. simpl in *. lia.
    + match goal with
      | St: step _ _, Val: value (Fld _ _) |- _ => dependent destruction St; dependent destruction Val
      end.
      eapply Con_Rcd. eapply IHCon; eauto 3. intros. eapply (IH e e'0); eauto. simpl in *. lia.
    + match goal with
      | St1: step _ _, St2: step _ _ |- _ => dependent destruction St1; dependent destruction St2
      end.
      eapply Con_Rcd. eapply IHCon; eauto 3. intros. eapply (IH e e'1); eauto. simpl in *. lia.
  - Case "Disjoint".
    dependent destruction Sv1; dependent destruction Sv2; eauto.
    + pose proof (step_uvalue _ _ Uv2 H3).
      eapply IH in H3; eauto; try lia.
      destruct H3 as [x Typ]; destruct Typ as [Typ Isub].
      eapply typing_to_ptype in Typ; eauto.
      eapply typing_to_ptype in Typ2; eauto. subst_ptype.
      eapply Con_Dj; eauto. eapply disjoint_iso_l; eauto.
    + pose proof (step_uvalue _ _ Uv1 H2).
      eapply IH in H2; eauto; try lia.
      destruct H2 as [x Typ]; destruct Typ as [Typ Isub].
      eapply typing_to_ptype in Typ; eauto.
      eapply typing_to_ptype in Typ1; eauto. subst_ptype.
      eapply Con_Dj; eauto. eapply disjoint_iso_l; eauto.
    + pose proof (step_uvalue _ _ Uv1 H2).
      pose proof (step_uvalue _ _ Uv2 H3).
      eapply IH in H2; eauto; try lia.
      eapply IH in H3; eauto; try lia.
      destruct_conjs.
      eapply typing_to_ptype in Typ1; eauto.
      eapply typing_to_ptype in Typ2; eauto. repeat subst_ptype.
      eapply Con_Dj; eauto. eapply disjoint_iso_l; eauto.
  - Case "Merge L".
    dependent destruction Sv1; eauto 3.
    + dependent destruction Typ1;
        eapply Con_Mrg_L; try solve [solver4 IHCon1 IH | solver4 IHCon2 IH].
    + dependent destruction Typ1;
        match goal with
        | St: step (Mrg _ _) _ |- _ => dependent destruction St
        end; eapply Con_Mrg_L; try solve [solver4 IHCon1 IH | solver4 IHCon2 IH].
  - Case "Merge R".
    dependent destruction Sv2; eauto 3.
    + dependent destruction Typ2;
        eapply Con_Mrg_R; try solve [solver4 IHCon1 IH | solver4 IHCon2 IH].
    + dependent destruction Typ2;
        match goal with
        | St: step (Mrg _ _) _ |- _ => dependent destruction St
        end; eapply Con_Mrg_R; try solve [solver4 IHCon1 IH | solver4 IHCon2 IH].
Qed.

End step_consistent.

(** * Preservation *)

Ltac ind_term_size s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : term |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => (dependent destruction H) end
    | intros ].

Theorem preservation :
  forall e e' A,
    typing nil e Inf A ->
    step e e' ->
    (exists B, typing nil e' Inf B /\ isosub B A).
Proof.
  introv Typ St. gen e' A.
  ind_term_size (size_term e). (* shelved item *)
  dependent destruction Typ; simpl in SizeInd.
  - Case "Lit".
    dependent destruction St; eauto.
    exists Int; eauto.
  - Case "Var".
    dependent destruction St.
  - Case "Lam".
    dependent destruction St; eauto.
    exists (Arr A B). split; eauto.
  - Case "Rcd".
    dependent destruction St; eauto.
    exploit (IH e); eauto; try lia. intros IH'. destruct_conjs.
    eexists. split; eauto.
  - Case "Ann".
    dependent destruction St.
    + SCase "Split".
      dependent destruction Typ.
      exists (And A1 A2). split; eauto.
      pose proof (sub_inv_splitable_r A B A1 A2) as Sub. destruct Sub; eauto.
      eapply Ty_Mrg_Uv; eauto.
    + SCase "Value".
      dependent destruction Typ.
      eapply casting_preservation; eauto.
    + SCase "Ann".
      dependent destruction Typ.
      eapply IH in St; eauto; try lia.
      destruct St as [C Typ']. destruct Typ' as [Typ'1 Typ'2].
      pose proof (isosub_to_sub1 _ _ Typ'2).
      exists B. split; eauto. eapply Ty_Ann; eauto; try solve [eapply sub_transitivity; eauto].
      eapply Ty_Sub; eauto. eapply sub_transitivity; eauto.
  - Case "App".
    dependent destruction St.
    + pose proof (papp_preservation_v e1 e2 e) as P.
      eapply P; eauto. now eapply uunisub_sound_appsub.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply uunisub_sound_appsub in H0.
      eapply appsub_iso_v in H0; eauto. destruct_conjs.
      eapply uunisub_complete_appsub in H3.
      eexists; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply uunisub_sound_appsub in H0.
      eapply appsub_iso_v in H0; eauto. destruct_conjs.
      eapply uunisub_complete_appsub in H3.
      eexists; eauto.
  - Case "Prj".
    dependent destruction St.
    + eapply uunisub_sound_appsub in H1.
      pose proof (papp_preservation_l e l e0) as P.
      eapply P; eauto.
    + eapply uunisub_sound_appsub in H.
      eapply IH in St; eauto; try lia. destruct_conjs.
      eapply appsub_iso_l in H; eauto. destruct_conjs.
      eapply uunisub_complete_appsub in H2.
      eexists; eauto.
  - Case "Merge".
    dependent destruction St.
    + eapply IH in St1; eauto; try lia.
      eapply IH in St2; eauto; try lia. destruct_conjs.
      eapply disjoint_iso_l in H; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply disjoint_iso_l in H0; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply disjoint_iso_l in H0; eauto.
  - Case "Merge U".
    dependent destruction St.
    + (* TODO: Automation *)
      assert (exists C, (typing nil e1' Inf C) /\ (isosub C A)) by (eapply IH; eauto; lia).
      assert (exists C, (typing nil e2' Inf C) /\ (isosub C B)) by (eapply IH; eauto; lia).
      destruct_conjs. exists (And H3 H4).
      pose proof (step_uvalue _ _ H0 St1).
      pose proof (step_uvalue _ _ H1 St2).
      split; eauto. eapply Ty_Mrg_Uv; eauto.
      pose proof (Sv_S _ _ St1) as Sov1.
      pose proof (Sv_S _ _ St2) as Sov2.
      pose proof (step_consistent u1 u2 e1' e2' A B H0 H1 Typ1 Typ2 H2 Sov1 Sov2) as Sc.
      eapply Sc. intros. eapply IH; eauto. lia.
    + assert (exists C, (typing nil e1' Inf C) /\ (isosub C A)) by (eapply IH; eauto; lia).
      destruct_conjs. exists (And H4 B).
      pose proof (step_uvalue _ _ H1 St).
      split; eauto. eapply Ty_Mrg_Uv; eauto.
      pose proof (Sv_S _ _ St) as Sov1.
      pose proof (Sv_V _ H) as Sov2.
      pose proof (step_consistent u1 u2 e1' u2 A B H1 H2 Typ1 Typ2 H3 Sov1 Sov2) as Sc.
      eapply Sc; eauto. intros. eapply IH; eauto. lia.
    + assert (exists C, (typing nil e2' Inf C) /\ (isosub C B)) by (eapply IH; eauto; lia).
      destruct_conjs. exists (And A H4).
      pose proof (step_uvalue _ _ H2 St).
      split; eauto. eapply Ty_Mrg_Uv; eauto.
      pose proof (Sv_V _ H) as Sov1.
      pose proof (Sv_S _ _ St) as Sov2.
      pose proof (step_consistent u1 u2 u1 e2' A B H1 H2 Typ1 Typ2 H3 Sov1 Sov2) as Sc.
      eapply Sc; eauto. intros. eapply IH; eauto. lia.
      Unshelve. eauto.
Qed.

(** * Progress *)

Theorem progress :
  forall e A dir,
    typing nil e dir A ->
    value e \/ exists e', step e e'.
Proof.
  introv Typ.
  dependent induction Typ; eauto 3.
  - Case "Rcd".
    destruct IHTyp as [Val | St] ; eauto.
    right. destruct St. exists (Fld l x); eauto.
  - Case "Anno".
    destruct IHTyp as [Val | St] ; eauto.
    + right. eapply casting_progress in Typ; eauto. destruct Typ.
      exists x. eapply St_Val; eauto.
    + destruct (pvalue_decidable e) as [Pv | nPv];
        destruct (splitable_or_ordinary A) as [Spl | Ord]; eauto.
      * destruct Pv; right; destruct_conjs; eexists; eauto.
      * destruct St. right. eexists; eauto.
      * destruct St. right. eexists; eauto.
  - Case "App".
    eapply uunisub_sound_appsub in H.
    right. destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
    pose proof (papp_progress_v e1 e2 A B C) as Pa. destruct Pa; eauto.
  - Case "Prj".
    eapply uunisub_sound_appsub in H.
    right. destruct IHTyp; eauto 3; try solve [destruct_conjs; eauto].
    pose proof (papp_progress_l e A B l) as Pa. destruct Pa; eauto.
  - Case "Merge".
    destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
  - Case "Merge V".
    destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** These are the notations whose level and associativity are imposed by Coq *)

(** Notations for propositional connectives *)

Reserved Notation "x <-> y" (at level 95, no associativity).
Reserved Notation "x /\ y" (at level 80, right associativity).
Reserved Notation "x \/ y" (at level 85, right associativity).
Reserved Notation "~ x" (at level 75, right associativity).

(** Notations for equality and inequalities *)

Reserved Notation "x = y  :>  T"
(at level 70, y at next level, no associativity).
Reserved Notation "x = y" (at level 70, no associativity).
Reserved Notation "x = y = z"
(at level 70, no associativity, y at next level).

Reserved Notation "x <> y  :>  T"
(at level 70, y at next level, no associativity).
Reserved Notation "x <> y" (at level 70, no associativity).

Reserved Notation "x <= y" (at level 70, no associativity).
Reserved Notation "x < y" (at level 70, no associativity).
Reserved Notation "x >= y" (at level 70, no associativity).
Reserved Notation "x > y" (at level 70, no associativity).

Reserved Notation "x <= y <= z" (at level 70, y at next level).
Reserved Notation "x <= y < z" (at level 70, y at next level).
Reserved Notation "x < y < z" (at level 70, y at next level).
Reserved Notation "x < y <= z" (at level 70, y at next level).

(** Arithmetical notations (also used for type constructors) *)

Reserved Notation "x + y" (at level 50, left associativity).
Reserved Notation "x - y" (at level 50, left associativity).
Reserved Notation "x * y" (at level 40, left associativity).
Reserved Notation "x / y" (at level 40, left associativity).
Reserved Notation "- x" (at level 35, right associativity).
Reserved Notation "/ x" (at level 35, right associativity).
Reserved Notation "x ^ y" (at level 30, right associativity).

(** Notations for booleans *)

Reserved Notation "x || y" (at level 50, left associativity).
Reserved Notation "x && y" (at level 40, left associativity).

(** Notations for pairs *)

Reserved Notation "( x , y , .. , z )" (at level 0).

(** Notation "{ x }" is reserved and has a special status as component
    of other notations such as "{ A } + { B }" and "A + { B }" (which
    are at the same level than "x + y");
    "{ x }" is at level 0 to factor with "{ x : A | P }" *)

Reserved Notation "{ x }" (at level 0, x at level 99).

(** Notations for sigma-types or subsets *)

Reserved Notation "{ x  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x  |  P  & Q }" (at level 0, x at level 99).

Reserved Notation "{ x : A  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x : A  |  P  & Q }" (at level 0, x at level 99).

Reserved Notation "{ x : A  & P }" (at level 0, x at level 99).
Reserved Notation "{ x : A  & P  & Q }" (at level 0, x at level 99).

Delimit Scope type_scope with type.
Delimit Scope core_scope with core.

Open Scope core_scope.
Open Scope type_scope.


Require Import LCSyntax.
Require Import STLCDefinition.
Require Import STLCTypeSoundness.
Require Import LCReduction.
Require Import MySequences.
Require Import MyTactics.

Fail Inductive R : ty -> term -> Prop :=
| Rvar : forall x t,
  (forall Gamma, jt Gamma t (TyVar x)) ->
  halts cbv t ->
  R (TyVar x) t
| Rapp : forall t T1 T2,
  halts cbv t ->
  (forall Gamma, jt Gamma t (TyFun T1 T2)) ->
  (forall s, R T1 s -> R T2 (App t s)) ->
  R (TyFun T1 T2) t
.

Fixpoint R (T: ty) (t: term) : Prop :=
  (forall Gamma, jt Gamma t T) /\ closed t /\ halts cbv t /\
  match T with
  | TyVar _ => True
  | TyFun T1 T2 =>
    (forall s, R T1 s -> R T2 (App t s))
  | TyOption T => True
  end
.

Lemma R_unfold:
  forall T t, R T t = (
  (forall Gamma, jt Gamma t T) /\ closed t /\ halts cbv t /\
  match T with
  | TyVar _ => True
  | TyFun T1 T2 =>
    (forall s, R T1 s -> R T2 (App t s))
  | TyOption T => True
  end)
.
Proof.
  intros; case T; simpl; try reflexivity.
Qed.

Lemma R_halts: forall T t, R T t -> halts cbv t.
Proof.
  induction T; intros; unfold R in *; unpack; eauto.
Qed.

Lemma R_typable: forall T t, R T t -> forall Gamma, jt Gamma t T.
Proof.
  induction T; intros; unfold R in *; unpack; eauto.
Qed.

Lemma cbv_preserves_halt:
  forall t t', cbv t t' -> halts cbv t -> halts cbv t'.
Proof.
  unfold halts.
  intros; unpack.
  induction H0.
  * unfold irred in *.
    false; eapply H1; eauto.
  * forwards: cbv_deterministic H H0; subst.
    eauto.
Qed.

Lemma cbv_preserves_closed:
  forall t t', cbv t t' -> closed t -> closed t'.
Proof.
  intros.
  induction H;
    try solve [ false; eauto 3 with obvious ];
    try solve [ unfold closed in *; fv; repeat split; unpack; eauto ].
  * unfold closed in *; fv.
    admit.
  * unfold closed in *; fv.
    admit.
  * unfold closed in *; fv.
    admit.
Admitted.

Lemma cbv_preserves_R:
  forall T t t', cbv t t' -> R T t -> R T t'.
Proof.
  induction T; intros; unfold R in *.
  * unpack; repeat split; intros;
    eauto using
      jt_preservation,
      cbv_preserves_closed,
      cbv_preserves_halt.
  * fold R in *; unpack; repeat split; intros;
    eauto using
      jt_preservation,
      cbv_preserves_closed,
      cbv_preserves_halt.
    - eapply IHT2.
      { eapply RedAppL; simpl; eauto. }
      eauto.
  * admit.
Admitted.

Lemma cbvstar_preserves_R:
  forall T t t', star cbv t t' -> R T t -> R T t'.
Proof.
  intros.
  induction H; eauto using cbv_preserves_R.
Qed.

Lemma halt_inv:
  forall t t', cbv t t' -> halts cbv t' -> halts cbv t.
Proof.
  unfold halts; intros; unpack.
  eexists; split; eauto. eauto with sequences.
Qed.

Lemma empty_typed_is_closed:
  forall t T, (forall Gamma, jt Gamma t T) -> closed t.
Proof.
  admit.
Admitted.

Lemma cbv_preserves_R_inv:
  forall T t t', (forall Gamma, jt Gamma t T) -> cbv t t' -> R T t' -> R T t.
Proof.
  induction T; intros; unfold R in *.
  * unpack; repeat split; intros;
    eauto using
      jt_preservation,
      cbv_preserves_closed,
      cbv_preserves_halt,
      empty_typed_is_closed,
      halt_inv.
  * fold R in *; unpack; repeat split; intros;
    eauto using
      jt_preservation,
      cbv_preserves_closed,
      cbv_preserves_halt,
      empty_typed_is_closed,
      halt_inv.
    - eapply IHT2.
      unfold R in H5; induction T1; unpack; fold R in *.
      { admit. } { admit. } { admit. }
      { eapply RedAppL; simpl; eauto. }
      eauto.
  * admit.
Admitted.

Print Acc.
Inductive Acc (A : Type) (R : A -> A -> Prop) (x : A) : Prop :=
  Acc_intro: (forall y: A, R y x -> Acc A R y) -> Acc A R x.

(* RPO *)

Lemma strong: forall Gamma T t, jt Gamma t T -> R T t.
Proof.
  intros.
  induction T.
  * admit.
  * admit.
  * admit.
Admitted.
(*
  * econstructor.
    induction H; subst; tryfalse.
    - econstructor.
      exists (Var x0); split; eauto with sequences.
      unfold irred; repeat intro. invert_cbv.
    - exists (Lam t); split; eauto with sequences.
      unfold irred; repeat intro. invert_cbv.
*)