From Coq Require Import List String.
Require Import FSet Config L10.AST.

Section Callset.

Context {C: VyperConfig}.

(** Get the set of functions called by an expression. *)
Fixpoint expr_callset (e: expr)
: string_set
:= let _ := string_set_impl in
   match e with
   | Const _ | LocalVar _ | StorageVar _ => empty
   | UnOp _ a => expr_callset a
   | BinOp _ a b
   | LogicalOr a b
   | LogicalAnd a b => union (expr_callset a) (expr_callset b)
   | IfThenElse a b c => union (expr_callset a) (union (expr_callset b) (expr_callset c))
   | PrivateOrBuiltinCall name args =>
      let fix expr_list_callset (exprs: list expr)
          := match exprs with
             | nil => empty
             | (h :: t)%list => union (expr_callset h) (expr_list_callset t)
             end
      in add (expr_list_callset args) name
   end.
Fixpoint expr_list_callset (exprs: list expr)
: string_set
:= let _ := string_set_impl in
   match exprs with
   | nil => empty
   | (h :: t)%list => union (expr_callset h) (expr_list_callset t)
   end.

Definition small_stmt_callset (s: small_stmt)
:= let _ := string_set_impl in
   match s with
   | Pass | Break | Continue | Return None | Revert => empty
   | Return (Some e) | Raise e | Assert e None | ExprStmt e =>
       expr_callset e
   | Assign lhs rhs | BinOpAssign lhs _ rhs => expr_callset rhs
   | Assert cond (Some error) => union (expr_callset cond) (expr_callset error)
   end.

Fixpoint stmt_callset (s: stmt)
:= let _ := string_set_impl in
   let fix stmt_list_callset (stmts: list stmt)
       := match stmts with
          | nil => empty
          | (h :: t)%list => union (stmt_callset h) (stmt_list_callset t)
          end
   in match s with
   | SmallStmt a => small_stmt_callset a
   | LocalVarDecl _ None => empty
   | LocalVarDecl _ (Some e) => expr_callset e
   | IfElseStmt cond yes None => union (expr_callset cond) (stmt_list_callset yes)
   | IfElseStmt cond yes (Some no) => union (expr_callset cond)
                                            (union (stmt_list_callset yes) (stmt_list_callset no))
   | FixedRangeLoop var start _ body => stmt_list_callset body
   | FixedCountLoop var start _ body => union (expr_callset start) (stmt_list_callset body)
   end.

Fixpoint stmt_list_callset (stmts: list stmt)
:= let _ := string_set_impl in
   match stmts with
   | nil => empty
   | (h :: t)%list => union (stmt_callset h) (stmt_list_callset t)
   end.

Definition stmt_list_callset' (stmts: list stmt)
:= let _ := string_set_impl in fold_right union empty (map stmt_callset stmts).

Ltac descend H
:= subst; cbn in H;
   repeat try rewrite union_subset_and in H;
   repeat rewrite Bool.andb_true_iff in H;
   try tauto.

Lemma stmt_list_callset_alt (s: list stmt):
  stmt_list_callset s = stmt_list_callset' s.
Proof.
induction s. { easy. }
cbn. f_equal. apply IHs.
Qed.

Definition decl_callset (d: decl)
:= let _ := string_set_impl in match d with
   | StorageVarDecl _ => empty
   | FunDecl name args body => stmt_list_callset body
   end.

Lemma callset_descend_unop {e a: expr} {op: unop}
                           {allowed_calls: string_set}
                           (E: e = UnOp op a)
                           (ok: let _ := string_set_impl in
                                FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset a) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_binop_left {e a b: expr} {op: binop}
                                 {allowed_calls: string_set}
                                 (E: e = BinOp op a b)
                                 (ok: let _ := string_set_impl in
                                      FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset a) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_binop_right {e a b: expr} {op: binop}
                                  {allowed_calls: string_set}
                                  (E: e = BinOp op a b)
                                  (ok: let _ := string_set_impl in
                                       FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset b) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_leaf {e: expr} {name: string} {args: list expr}
                   {allowed_calls: string_set}
                   (E: e = PrivateOrBuiltinCall name args)
                   (ok: let _ := string_set_impl in
                         FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.has allowed_calls name = true.
Proof.
subst e. cbn in ok.
rewrite FSet.is_subset_ok in ok.
assert (Ok := ok name). clear ok.
rewrite FSet.add_ok in Ok.
destruct (string_dec name name). 2:{ tauto. }
cbn.
destruct (FSet.has allowed_calls name). { trivial. }
cbn in Ok. discriminate.
Qed.

Lemma callset_descend_args {e: expr} {name: string} {args: list expr}
                           {allowed_calls: string_set}
                           (E: e = PrivateOrBuiltinCall name args)
                           (ok: let _ := string_set_impl in
                                FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_list_callset args) allowed_calls = true.
Proof.
subst e. cbn in *.
unfold expr_list_callset.
apply (FSet.is_subset_trans (FSet.add_subset _ _) ok).
Qed.

Lemma callset_descend_head {h: expr} {t e: list expr}
                           {allowed_calls: string_set}
                           (E: e = (h :: t)%list)
                           (ok: let _ := string_set_impl in
                           FSet.is_subset (expr_list_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset h) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_tail {h: expr} {t e: list expr}
                           {allowed_calls: string_set}
                           (E: e = (h :: t)%list)
                           (ok: let _ := string_set_impl in
                           FSet.is_subset (expr_list_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_list_callset t) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_if_cond {cond yes no e: expr}
                              {allowed_calls: string_set}
                              (E: e = IfThenElse cond yes no)
                              (ok: let _ := string_set_impl in
                                   FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset cond) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_if_then {cond yes no e: expr}
                              {allowed_calls: string_set}
                              (E: e = IfThenElse cond yes no)
                              (ok: let _ := string_set_impl in
                                   FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset yes) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_if_else {cond yes no e: expr}
                              {allowed_calls: string_set}
                              (E: e = IfThenElse cond yes no)
                              (ok: let _ := string_set_impl in
                                   FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset no) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_and_left {a b e: expr}
                               {allowed_calls: string_set}
                               (E: e = LogicalAnd a b)
                               (ok: let _ := string_set_impl in
                                    FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset a) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_and_right {a b e: expr}
                                {allowed_calls: string_set}
                                (E: e = LogicalAnd a b)
                                (ok: let _ := string_set_impl in
                                     FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset b) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_or_left {a b e: expr}
                              {allowed_calls: string_set}
                              (E: e = LogicalOr a b)
                              (ok: let _ := string_set_impl in
                                   FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset a) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_or_right {a b e: expr}
                               {allowed_calls: string_set}
                               (E: e = LogicalOr a b)
                               (ok: let _ := string_set_impl in
                                    FSet.is_subset (expr_callset e) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset b) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_return {s: small_stmt} {e: expr}
                             {allowed_calls: string_set}
                             (E: s = Return (Some e))
                             (ok: let _ := string_set_impl in
                                  FSet.is_subset (small_stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset e) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_raise {s: small_stmt} {e: expr}
                            {allowed_calls: string_set}
                            (E: s = Raise e)
                            (ok: let _ := string_set_impl in
                                 FSet.is_subset (small_stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset e) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_expr_stmt {s: small_stmt} {e: expr}
                                {allowed_calls: string_set}
                                (E: s = ExprStmt e)
                                (ok: let _ := string_set_impl in
                                     FSet.is_subset (small_stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset e) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_assert_cond {s: small_stmt} {cond: expr} {maybe_e: option expr}
                                  {allowed_calls: string_set}
                                  (E: s = Assert cond maybe_e)
                                  (ok: let _ := string_set_impl in
                                       FSet.is_subset (small_stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset cond) allowed_calls = true.
Proof.
subst. cbn in *. destruct maybe_e; cbn in ok; descend ok.
Qed.

Lemma callset_descend_assert_error {s: small_stmt} {cond e: expr} {maybe_e: option expr}
                                   {allowed_calls: string_set}
                                   (E: s = Assert cond maybe_e)
                                   (Ee: maybe_e = Some e)
                                   (ok: let _ := string_set_impl in
                                        FSet.is_subset (small_stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset e) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_assign_rhs {s: small_stmt} {lhs: assignable} {rhs: expr}
                                 {allowed_calls: string_set}
                                 (E: s = Assign lhs rhs)
                                 (ok: let _ := string_set_impl in
                                      FSet.is_subset (small_stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset rhs) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_binop_assign_rhs {s: small_stmt} {lhs: assignable} {rhs: expr}
                                       {allowed_calls: string_set}
                                       {op: binop}
                                       (E: s = BinOpAssign lhs op rhs)
                                       (ok: let _ := string_set_impl in
                                            FSet.is_subset (small_stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset rhs) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_small_stmt {s: stmt} {ss: small_stmt}
                                 {allowed_calls: string_set}
                                 (E: s = SmallStmt ss)
                                 (ok: let _ := string_set_impl in
                                      FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (small_stmt_callset ss) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_stmt_if_cond {cond: expr} {yes: list stmt} {no: option (list stmt)} {s: stmt}
                                   {allowed_calls: string_set}
                                   (E: s = IfElseStmt cond yes no)
                                   (ok: let _ := string_set_impl in
                                        FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset cond) allowed_calls = true.
Proof.
destruct no; descend ok.
Qed.

Lemma callset_descend_stmt_if_then {cond: expr} {yes: list stmt} {no: option (list stmt)} {s: stmt}
                                   {allowed_calls: string_set}
                                   (E: s = IfElseStmt cond yes no)
                                   (ok: let _ := string_set_impl in
                                        FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_list_callset yes) allowed_calls = true.
Proof.
destruct no; descend ok.
Qed.

Lemma callset_descend_stmt_if_else {cond: expr} {yes no: list stmt}
                                   {maybe_no: option (list stmt)} {s: stmt}
                                   {allowed_calls: string_set}
                                   (E: s = IfElseStmt cond yes maybe_no)
                                   (Eno: maybe_no = Some no)
                                   (ok: let _ := string_set_impl in
                                        FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_list_callset no) allowed_calls = true.
Proof.
subst. cbn in *. descend ok.
Qed.

Lemma callset_descend_init_expr {stmts t: list stmt} {s: stmt} {init: expr}
                                {allowed_calls: string_set}
                                (E: stmts = s :: t)
                                (Evar: is_local_var_decl s = true)
                                (Einit: snd (var_decl_unpack s Evar) = Some init)
                                (ok: let _ := string_set_impl in
                                     FSet.is_subset (stmt_list_callset stmts) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset init) allowed_calls = true.
Proof.
cbn in *. destruct s; cbn in Evar; try discriminate.
cbn in *. subst. descend ok.
Qed.

Lemma callset_descend_stmt_head {stmts tail: list stmt} {head: stmt}
                                {allowed_calls: string_set}
                                (E: stmts = head :: tail)
                                (ok: let _ := string_set_impl in
                                     FSet.is_subset (stmt_list_callset stmts) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_callset head) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_stmt_tail {stmts tail: list stmt} {head: stmt}
                                {allowed_calls: string_set}
                                (E: stmts = head :: tail)
                                (ok: let _ := string_set_impl in
                                     FSet.is_subset (stmt_list_callset stmts) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_list_callset tail) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_fixed_range_loop_body {s: stmt} {body: list stmt} {var start stop}
                                            {allowed_calls: string_set}
                                            (E: s = FixedRangeLoop var start stop body)
                                (ok: let _ := string_set_impl in
                                     FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_list_callset body) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_fixed_count_loop_body {s: stmt} {body: list stmt} {var start stop}
                                            {allowed_calls: string_set}
                                            (E: s = FixedCountLoop var start stop body)
                                (ok: let _ := string_set_impl in
                                     FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (stmt_list_callset body) allowed_calls = true.
Proof.
descend ok.
Qed.

Lemma callset_descend_fixed_count_loop_start {s: stmt} {body: list stmt} {var start count}
                                             {allowed_calls: string_set}
                                             (E: s = FixedCountLoop var start count body)
                                (ok: let _ := string_set_impl in
                                     FSet.is_subset (stmt_callset s) allowed_calls = true):
  let _ := string_set_impl in
  FSet.is_subset (expr_callset start) allowed_calls = true.
Proof.
descend ok.
Qed.

End Callset.


Require Import List Arith Bool.
Require Import Expr Env.
Require Import Reflection.

Set Implicit Arguments.
Set Strict Implicit.

(** Provers that establish [expr]-encoded facts *)

Definition ProverCorrect types (fs : functions types) (summary : Type)
    (** Some prover work only needs to be done once per set of hypotheses,
       so we do it once and save the outcome in a summary of this type. *)
  (valid : env types -> env types -> summary -> Prop)
  (prover : summary -> expr types -> bool) : Prop :=
  forall vars uvars sum,
    valid uvars vars sum ->
    forall goal,
      prover sum goal = true ->
      ValidProp fs uvars vars goal ->
      Provable fs uvars vars goal.

Record ProverT (types : list type) : Type :=
{ Facts : Type
; Summarize : exprs types -> Facts
; Learn : Facts -> exprs types -> Facts
; Prove : Facts -> expr types -> bool
}.

Record ProverT_correct (types : list type) (P : ProverT types) (funcs : functions types) : Type :=
{ Valid : env types -> env types -> Facts P -> Prop
; Valid_weaken : forall u g f ue ge,
  Valid u g f -> Valid (u ++ ue) (g ++ ge) f
; Summarize_correct : forall uvars vars hyps,
  AllProvable funcs uvars vars hyps ->
  Valid uvars vars (Summarize P hyps)
; Learn_correct : forall uvars vars facts,
  Valid uvars vars facts -> forall hyps,
  AllProvable funcs uvars vars hyps ->
  Valid uvars vars (Learn P facts hyps)
; Prove_correct : ProverCorrect funcs Valid (Prove P)
}.

Record ProverPackage : Type :=
{ ProverTypes : Repr type
; ProverFuncs : forall ts, Repr (signature (repr ProverTypes ts))
; Prover : forall ts, ProverT (repr ProverTypes ts)
; Prover_correct : forall ts fs,
  ProverT_correct (Prover ts) (repr (ProverFuncs ts) fs)
}.

(** Generic lemmas/tactis to prove things about provers **)

Hint Rewrite EquivDec_refl_left SemiDec_EquivDec_refl_left : provers.

(* Everything looks like a nail?  Try this hammer. *)
Ltac t1 := match goal with
             | _ => discriminate
             | _ => progress (hnf in *; simpl in *; intuition; subst)
             | [ x := _ : _ |- _ ] => subst x || (progress (unfold x in * ))
             | [ H : ex _ |- _ ] => destruct H
             | [ H : context[nth_error (updateAt ?new ?ls ?n) ?n] |- _ ] =>
               rewrite (nth_error_updateAt new ls n) in H
                 || rewrite nth_error_updateAt in H
             | [ s : signature _ |- _ ] => destruct s
             | [ H : Some _ = Some _ |- _ ] => injection H; clear H
             | [ H : _ = Some _ |- _ ] => rewrite H in *
             | [ H : _ === _ |- _ ] => rewrite H in *

             | [ |- context[match ?E with
                              | Const _ _ => _
                              | Var _ => _
                              | UVar _ => _
                              | Func _ _ => _
                              | Equal _ _ _ => _
                              | Not _ => _
                            end] ] => destruct E
             | [ |- context[match ?E with
                              | None => _
                              | Some _ => _
                            end] ] => destruct E
             | [ |- context[if ?E then _ else _] ] =>
               consider E; intro
             | [ |- context[match ?E with
                              | nil => _
                              | _ :: _ => _
                            end] ] => destruct E
             | [ H : _ || _ = true |- _ ] => apply orb_true_iff in H; destruct H
             | [ _ : context[match ?E with
                               | Const _ _ => _
                               | Var _ => _
                               | UVar _ => _
                               | Func _ _ => _
                               | Equal _ _ _ => _
                               | Not _ => _
                             end] |- _ ] => destruct E
             | [ _ : context[match ?E with
                               | nil => _
                               | _ :: _ => _
                             end] |- _ ] => destruct E
             | [ H : context[if ?E then _ else _] |- _ ] =>
               revert H; consider E; try do 2 intro
             | [ _ : context[match ?E with
                               | left _ => _
                               | right _ => _
                             end] |- _ ] => destruct E
             | [ _ : context[match ?E with
                               | tvProp => _
                               | tvType _ => _
                             end] |- _ ] => destruct E
             | [ _ : context[match ?E with
                               | None => _
                               | Some _ => _
                             end] |- _ ] => match E with
                                              | context[match ?E with
                                                          | None => _
                                                          | Some _ => _
                                                  end] => fail 1
                                              | _ => destruct E
                                            end

             | [ _ : context[match ?E with (_, _) => _ end] |- _ ] => destruct E
           end.

Ltac t := repeat t1; eauto.

(** Composite Prover **)
Section composite.
  Variable types : list type.
  Variables pl pr : ProverT types.

  Definition composite_ProverT : ProverT types :=
  {| Facts := Facts pl * Facts pr
   ; Summarize := fun hyps =>
     (Summarize pl hyps, Summarize pr hyps)
   ; Learn := fun facts hyps =>
     let (fl,fr) := facts in
     (Learn pl fl hyps, Learn pr fr hyps)
   ; Prove := fun facts goal =>
     let (fl,fr) := facts in
     (Prove pl fl goal) || (Prove pr fr goal)
   |}.

  Variable funcs : functions types.
  Variable pl_correct : ProverT_correct pl funcs.
  Variable pr_correct : ProverT_correct pr funcs.

  Theorem composite_ProverT_correct : ProverT_correct composite_ProverT funcs.

    refine (
      {| Valid := fun uvars vars (facts : Facts composite_ProverT) =>
        let (fl,fr) := facts in
          Valid pl_correct uvars vars fl /\ Valid pr_correct uvars vars fr
      |}); destruct pl_correct; destruct pr_correct; simpl; try destruct facts; intuition eauto.
    unfold ProverCorrect. destruct sum; intuition.
    apply orb_true_iff in H.
    destruct H; eauto.
  Qed.
End composite.


Require Import GL4ip_PSGL4ip_calcs.
Require Import List.
Export ListNotations.

Require Import genT gen.
Require Import ddT.
Require Import gen_tacs.
Require Import gen_seq.
Require Import List_lemmasT.
Require Import existsT.
Require Import univ_gen_ext.
Require Import GL4ip_PSGL4ip_list_lems.
Require Import dd_fc.
Require Import PeanoNat.
Require Import strong_inductionT.
Require Import GL4ip_exch.
Require Import GL4ip_wkn.
Require Import GL4ip_PSGL4ip_remove_list.
Require Import GL4ip_PSGL4ip_dec.
Require Import GL4ip_ImpL_adm.
Require Import GL4ip_inv_ImpR.
Require Import Lia.

Theorem ImpImpL_inv_L :  forall n s (D0 : derrec GL4ip_rules (fun _ => False) s) A B C D Γ0 Γ1,
                              (n = derrec_height D0) ->
                              (s = (Γ0 ++ (A  → B) → D :: Γ1, C)) ->
                              derrec GL4ip_rules (fun _ => False) (Γ0 ++ A :: B → D :: B → D :: Γ1, C).
Proof.
assert (DersNilF: dersrec GL4ip_rules (fun _ : Seq  => False) []).
apply dersrec_nil.
(* Setting up the strong induction on the height. *)
pose (strong_inductionT (fun (x:nat) => forall s (D0 : derrec GL4ip_rules (fun _ => False) s) A B C D Γ0 Γ1,
                              (x = derrec_height D0) ->
                              (s = (Γ0 ++ (A  → B) → D :: Γ1, C)) ->
                              derrec GL4ip_rules (fun _ => False) (Γ0 ++ A :: B → D :: B → D :: Γ1, C))).
apply d. intros n IH. clear d.
(* Now we do the actual proof-theoretical work. *)
intros s D0. remember D0 as D0'. destruct D0.
(* D0 is a leaf *)
- destruct f.
(* D0 is ends with an application of rule *)
- intros A B C D Γ0 Γ1 hei eq. inversion g ; subst.
  (* IdP *)
  * inversion H. subst. assert (InT # P (Γ0 ++  (A  → B) → D :: Γ1)).
    rewrite <- H2. apply InT_or_app. right. apply InT_eq. assert (InT # P (Γ0 ++ A :: B → D :: B → D :: Γ1)).
    apply InT_app_or in H0. destruct H0. apply InT_or_app. auto. apply InT_or_app. right. inversion i.
    subst. inversion H1. subst. repeat apply InT_cons. auto.
    apply InT_split in H1. destruct H1. destruct s. rewrite e. assert (IdPRule [] (x ++ # P :: x0, # P)).
    apply IdPRule_I. apply IdP in H1.
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (x ++ # P :: x0, # P) H1 DersNilF). auto.
  (* BotL *)
  * inversion H. subst. assert (InT (⊥) (Γ0 ++  (A  → B) → D :: Γ1)).
    rewrite <- H2. apply InT_or_app. right. apply InT_eq. assert (InT (⊥) (Γ0 ++ A :: B → D :: B → D :: Γ1)).
    apply InT_app_or in H0. destruct H0. apply InT_or_app. auto. apply InT_or_app. right. inversion i.
    subst. inversion H1. subst. repeat apply InT_cons. auto. apply InT_split in H1. destruct H1. destruct s. rewrite e.
    assert (BotLRule [] (x ++ ⊥ :: x0, C)). apply BotLRule_I. apply BotL in H1.
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
    (ps:=[]) (x ++ ⊥ :: x0, C) H1 DersNilF). auto.
   (* AndR *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
    simpl in IH.
    assert (J2: derrec_height x < S (dersrec_height d)). lia.
    assert (J3: derrec_height x = derrec_height x). reflexivity.
    assert (J4 : (Γ0 ++  (A  → B) → D :: Γ1, A0) = (Γ0 ++  (A  → B) → D :: Γ1, A0)). auto.
    pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
    assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
    assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
    assert (J7 : (Γ0 ++  (A  → B) → D :: Γ1, B0) = (Γ0 ++  (A  → B) → D :: Γ1, B0)). auto.
    pose (IH _ J5 _ x0 _ _ _ _ _ _ J6 J7).
    assert (AndRRule [(Γ0 ++ A :: B → D :: B → D :: Γ1, A0); (Γ0 ++ A :: B → D :: B → D :: Γ1, B0)]
    (Γ0 ++ A :: B → D :: B → D :: Γ1, A0 ∧ B0)). apply AndRRule_I. pose (dlCons d1 DersNilF). pose (dlCons d0 d2).
    apply AndR in H0.
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
   (ps:=[(Γ0 ++ A :: B → D :: B → D :: Γ1, A0); (Γ0 ++ A :: B → D :: B → D :: Γ1, B0)])
    (Γ0 ++ A :: B → D :: B → D :: Γ1, A0 ∧ B0) H0 d3). auto.
  (* AndL *)
  * inversion H. subst. apply list_split_form in H2. destruct H2. repeat destruct s ; repeat destruct p ; subst.
   + inversion e0.
   + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
      assert (J2: derrec_height x < S (dersrec_height d)). lia.
      assert (J3: derrec_height x = derrec_height x). reflexivity.
      assert (J4 : (((Γ0 ++ [ (A  → B) → D]) ++ x0) ++ A0 :: B0 :: Γ3, C) = (Γ0 ++  (A  → B) → D :: x0 ++ A0 :: B0 :: Γ3, C)).
      repeat rewrite <- app_assoc. auto.
      pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
      assert (AndLRule [((Γ0 ++ A :: B → D :: B → D :: x0) ++ A0 :: B0 :: Γ3, C)]
       ((Γ0 ++ A :: B → D :: B → D :: x0) ++ A0 ∧ B0 :: Γ3, C)). apply AndLRule_I. repeat rewrite <- app_assoc in H0. simpl in H0.
       pose (dlCons d0 DersNilF). apply AndL in H0.
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(Γ0 ++ A :: B → D :: B → D :: x0 ++ A0 :: B0 :: Γ3, C)])
       (Γ0 ++ A :: B → D :: B → D :: x0 ++ A0 ∧ B0 :: Γ3, C) H0 d1). auto.
  +  repeat destruct s. repeat destruct p ; subst.
      assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
      assert (J2: derrec_height x0 < S (dersrec_height d)). lia.
      assert (J3: derrec_height x0 = derrec_height x0). reflexivity.
      assert (J4 : (Γ2 ++ A0 :: B0 :: x ++  (A  → B) → D :: Γ1, C) = ((Γ2 ++ A0 :: B0 :: x) ++  (A  → B) → D :: Γ1, C)).
      repeat rewrite <- app_assoc. auto. pose (IH _ J2 _ x0 _ _ _ _ _ _ J3 J4).
      pose (dlCons d0 DersNilF).
      assert (AndLRule [((Γ2 ++ A0 :: B0 :: x) ++ A :: B → D :: B → D :: Γ1, C)]
       ((Γ2 ++ A0 ∧ B0 :: x) ++ A :: B → D :: B → D :: Γ1, C)). repeat rewrite <- app_assoc. apply AndLRule_I.
       apply AndL in H0.
      pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
      (ps:=[((Γ2 ++ A0 :: B0 :: x) ++ A :: B → D :: B → D :: Γ1, C)])
      ((Γ2 ++ A0 ∧ B0 :: x) ++ A :: B → D :: B → D :: Γ1, C) H0 d1). auto.
  (* OrR1 *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl.
    assert (J2: derrec_height x < S (dersrec_height d)). lia.
    assert (J3: derrec_height x = derrec_height x). reflexivity.
    assert (J4 : (Γ0 ++  (A  → B) → D :: Γ1, A0) = (Γ0 ++  (A  → B) → D :: Γ1, A0)). auto.
    pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
    assert (OrR1Rule [(Γ0 ++ A :: B → D :: B → D :: Γ1, A0)]
    (Γ0 ++ A :: B → D :: B → D :: Γ1, Or A0 B0)). apply OrR1Rule_I. pose (dlCons d0 DersNilF).
    apply OrR1 in H0.
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
    (ps:=[(Γ0 ++ A :: B → D :: B → D :: Γ1, A0)])
    (Γ0 ++ A :: B → D :: B → D  :: Γ1, Or A0 B0) H0 d1). auto.
  (* OrR2 *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). repeat destruct s. simpl.
    assert (J2: derrec_height x < S (dersrec_height d)). lia.
    assert (J3: derrec_height x = derrec_height x). reflexivity.
    assert (J4 : (Γ0 ++  (A  → B) → D :: Γ1, B0) = (Γ0 ++  (A  → B) → D :: Γ1, B0)). auto.
    pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
    assert (OrR2Rule [(Γ0 ++ A :: B → D :: B → D :: Γ1, B0)]
    (Γ0 ++ A :: B → D :: B → D :: Γ1, Or A0 B0)). apply OrR2Rule_I. pose (dlCons d0 DersNilF).
    apply OrR2 in H0.
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
    (ps:=[(Γ0 ++ A :: B → D :: B → D :: Γ1, B0)])
    (Γ0 ++ A :: B → D :: B → D  :: Γ1, Or A0 B0) H0 d1). auto.
  (* OrL *)
  * inversion H. subst. apply list_split_form in H2. destruct H2. repeat destruct s ; repeat destruct p ; subst.
   + inversion e0.
   + assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
      assert (J2: derrec_height x < S (dersrec_height d)). lia.
      assert (J3: derrec_height x = derrec_height x). reflexivity.
      assert (J4 : (((Γ0 ++ [ (A  → B) → D]) ++ x0) ++ A0 :: Γ3, C) = (Γ0 ++  (A  → B) → D :: (x0 ++ A0 :: Γ3), C)). repeat rewrite <- app_assoc. auto.
      pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
      assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
      assert (J7 : (((Γ0 ++ [ (A  → B) → D]) ++ x0) ++ B0 :: Γ3, C) = (Γ0 ++  (A  → B) → D :: (x0 ++ B0 :: Γ3), C)). repeat rewrite <- app_assoc. auto.
      pose (IH _ J5 _ x1 _ _ _ _ _ _ J6 J7).
      assert (OrLRule [((Γ0 ++ A :: B → D :: B → D :: x0) ++ A0 :: Γ3, C);((Γ0 ++ A :: B → D :: B → D :: x0) ++ B0 :: Γ3, C)]
      ((Γ0 ++ A :: B → D :: B → D :: x0) ++ A0 ∨ B0 :: Γ3, C)). apply OrLRule_I. apply OrL in H0.
      repeat rewrite <- app_assoc in H0. simpl in H0.
      pose (dlCons d1 DersNilF). pose (dlCons d0 d2).
      pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
      (ps:=[(Γ0 ++ A :: B → D :: B → D :: x0 ++ A0 :: Γ3, C); (Γ0 ++ A :: B → D :: B → D :: x0 ++ B0 :: Γ3, C)])
      (Γ0 ++ A :: B → D :: B → D :: x0 ++ A0 ∨ B0 :: Γ3, C) H0 d3). auto.
   + repeat destruct s. repeat destruct p ; subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
      pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s.
      assert (J2: derrec_height x0 < S (dersrec_height d)). lia.
      assert (J3: derrec_height x0 = derrec_height x0). reflexivity.
      assert (J4 :(Γ2 ++ A0 :: x ++  (A  → B) → D :: Γ1, C) = ((Γ2 ++ A0 :: x) ++  (A  → B) → D :: Γ1, C)). repeat rewrite <- app_assoc. auto.
      pose (IH _ J2 _ x0 _ _ _ _ _ _ J3 J4).
      assert (J5: derrec_height x1 < S (dersrec_height d)). lia.
      assert (J6: derrec_height x1 = derrec_height x1). reflexivity.
      assert (J7 : (Γ2 ++ B0 :: x ++  (A  → B) → D :: Γ1, C) = ((Γ2 ++ B0 :: x) ++  (A  → B) → D :: Γ1, C)). repeat rewrite <- app_assoc. auto.
      pose (IH _ J5 _ x1 _ _ _ _ _ _ J6 J7).
      assert (OrLRule [((Γ2 ++ A0 :: x) ++ A :: B → D :: B → D :: Γ1, C);((Γ2 ++ B0 :: x) ++ A :: B → D :: B → D :: Γ1, C)]
      ((Γ2 ++ A0 ∨ B0 :: x) ++ A :: B → D :: B → D :: Γ1, C)). repeat rewrite <- app_assoc. apply OrLRule_I. apply OrL in H0.
      pose (dlCons d1 DersNilF). pose (dlCons d0 d2).
      pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
      (ps:=[((Γ2 ++ A0 :: x) ++ A :: B → D :: B → D :: Γ1, C); ((Γ2 ++ B0 :: x) ++ A :: B → D :: B → D :: Γ1, C)])
      ((Γ2 ++ A0 ∨ B0 :: x) ++ A :: B → D :: B → D :: Γ1, C) H0 d3). auto.
  (* ImpR *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
    assert (J50: derrec_height x = derrec_height x). auto.
    assert (J51: list_exch_L (Γ2 ++ A0 :: Γ3, B0) (A0 :: Γ0 ++  (A  → B) → D :: Γ1, B0)).
    assert (Γ2 ++ A0 :: Γ3 = [] ++ [] ++ Γ2 ++ [A0] ++ Γ3). auto. rewrite H0.
    assert (A0 :: Γ0 ++  (A  → B) → D :: Γ1 = [] ++ [A0] ++ Γ2 ++ [] ++ Γ3). rewrite <- H2. auto. rewrite H1.
    apply list_exch_LI.
    pose (GL4ip_hpadm_list_exch_L (derrec_height x) _ x J50 _ J51). destruct s.
    assert (J2: derrec_height x0 < S (dersrec_height d)). lia.
    assert (J3: derrec_height x0 = derrec_height x0). reflexivity.
    assert (J4: (A0 :: Γ0 ++  (A  → B) → D :: Γ1, B0) = ((A0 :: Γ0) ++  (A  → B) → D :: Γ1, B0)). repeat rewrite <- app_assoc. auto.
    pose (IH _ J2 _ x0 _ _ _ _ _ _ J3 J4).
    assert (ImpRRule [(([] ++ A0 :: Γ0) ++ A :: B → D :: B → D :: Γ1, B0)] ([] ++ Γ0 ++ A :: B → D :: B → D :: Γ1, A0 → B0)). repeat rewrite <- app_assoc. apply ImpRRule_I.
    simpl in H0. apply ImpR in H0. pose (dlCons d0 DersNilF).
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
    (ps:=[((A0 :: Γ0) ++ A :: B → D :: B → D :: Γ1, B0)]) (Γ0 ++ A :: B → D :: B → D :: Γ1, A0 → B0) H0 d1). auto.
  (* AtomImpL1 *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
    apply list_split_form in H2. destruct H2. repeat destruct s ; repeat destruct p ; subst.
   + inversion e1.
   + assert (J2: derrec_height x < S (dersrec_height d)). lia.
       assert (J3: derrec_height x = derrec_height x). reflexivity.
       assert (J4: (((Γ0 ++ [ (A  → B) → D]) ++ x1) ++ # P :: Γ3 ++ A0 :: Γ4, C) = (Γ0 ++  (A  → B) → D :: x1 ++ # P :: Γ3 ++ A0 :: Γ4, C)). repeat rewrite <- app_assoc. auto.
       pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
       assert (AtomImpL1Rule [((Γ0 ++ A :: B → D :: B → D :: x1) ++ # P :: Γ3 ++ A0 :: Γ4, C)]
       ((Γ0 ++ A :: B → D :: B → D :: x1) ++ # P :: Γ3 ++ # P → A0 :: Γ4, C)). apply AtomImpL1Rule_I.
       repeat rewrite <- app_assoc in H0. apply AtomImpL1 in H0.
       pose (dlCons d0 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(Γ0 ++ A :: B → D :: B → D :: x1 ++ # P :: Γ3 ++ A0 :: Γ4, C)])
       (Γ0 ++ A :: B → D :: B → D :: x1 ++ # P :: Γ3 ++ # P → A0 :: Γ4, C) H0 d1). auto.
   + repeat destruct s. repeat destruct p ; subst.
      apply list_split_form in e1. destruct e1. repeat destruct s ; repeat destruct p ; subst.
      { inversion e1. }
      { assert (J2: derrec_height x < S (dersrec_height d)). lia.
         assert (J3: derrec_height x = derrec_height x). reflexivity.
         assert (J4: (Γ2 ++ # P :: ((x0 ++ [ (A  → B) → D]) ++ x2) ++ A0 :: Γ4, C) = ((Γ2 ++ # P :: x0) ++  (A  → B) → D :: x2 ++ A0 :: Γ4, C)). repeat rewrite <- app_assoc. auto.
         pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
         assert (AtomImpL1Rule [((Γ2 ++ # P :: x0) ++ A :: B → D :: B → D :: x2 ++ A0 :: Γ4, C)]
         ((Γ2 ++ # P :: x0) ++ A :: B → D :: B → D :: x2 ++ # P → A0 :: Γ4, C)).
         assert ((Γ2 ++ # P :: x0) ++ A :: B → D :: B → D :: x2 ++ A0 :: Γ4 = Γ2 ++ # P :: (x0 ++ A :: B → D :: B → D :: x2) ++ A0 :: Γ4). repeat rewrite <- app_assoc. auto.
         rewrite H0.
         assert ((Γ2 ++ # P :: x0) ++ A :: B → D :: B → D :: x2 ++ # P → A0 :: Γ4 = Γ2 ++ # P :: (x0 ++ A :: B → D :: B → D :: x2) ++ # P → A0 :: Γ4). repeat rewrite <- app_assoc. auto.
         rewrite H1. apply AtomImpL1Rule_I. apply AtomImpL1 in H0. pose (dlCons d0 DersNilF).
         pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
         (ps:=[((Γ2 ++ # P :: x0) ++ A :: B → D :: B → D :: x2 ++ A0 :: Γ4, C)])
         ((Γ2 ++ # P :: x0) ++ A :: B → D :: B → D :: x2 ++ # P → A0 :: Γ4, C) H0 d1). auto. }
      { repeat destruct s. repeat destruct p ; subst.
         assert (J2: derrec_height x < S (dersrec_height d)). lia.
         assert (J3: derrec_height x = derrec_height x). reflexivity.
         assert (J4: (Γ2 ++ # P :: Γ3 ++ A0 :: x1 ++  (A  → B) → D :: Γ1, C) = ((Γ2 ++ # P :: Γ3 ++ A0 :: x1) ++  (A  → B) → D :: Γ1, C)).
         repeat rewrite <- app_assoc ; simpl ; repeat rewrite <- app_assoc ; auto.
         pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
         assert (AtomImpL1Rule [((Γ2 ++ # P :: Γ3 ++ A0 :: x1) ++ A :: B → D :: B → D :: Γ1, C)]
         ((Γ2 ++ # P :: Γ3 ++ # P → A0 :: x1) ++ A :: B → D :: B → D :: Γ1, C)). repeat rewrite <- app_assoc. simpl. repeat rewrite <- app_assoc.
         apply AtomImpL1Rule_I. apply AtomImpL1 in H0. pose (dlCons d0 DersNilF).
         pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
         (ps:=[((Γ2 ++ # P :: Γ3 ++ A0 :: x1) ++ A :: B → D :: B → D :: Γ1, C)])
         ((Γ2 ++ # P :: Γ3 ++ # P → A0 :: x1) ++ A :: B → D :: B → D :: Γ1, C) H0 d1). auto. }
  (* AtomImpL2 *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
    apply list_split_form in H2. destruct H2. repeat destruct s ; repeat destruct p ; subst.
   + inversion e1.
   + assert (J2: derrec_height x < S (dersrec_height d)). lia.
       assert (J3: derrec_height x = derrec_height x). reflexivity.
       assert (J4: (((Γ0 ++ [ (A  → B) → D]) ++ x1) ++ A0 :: Γ3 ++ # P :: Γ4, C) = (Γ0 ++  (A  → B) → D :: x1 ++ A0 :: Γ3 ++ # P :: Γ4, C)). repeat rewrite <- app_assoc. auto.
       pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
       assert (AtomImpL2Rule [((Γ0 ++ A :: B → D :: B → D :: x1) ++ A0 :: Γ3 ++ # P :: Γ4, C)]
       ((Γ0 ++ A :: B → D :: B → D :: x1) ++ # P → A0 :: Γ3 ++ # P :: Γ4, C)). apply AtomImpL2Rule_I.
       repeat rewrite <- app_assoc in H0. apply AtomImpL2 in H0.
       pose (dlCons d0 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(Γ0 ++ A :: B → D :: B → D :: x1 ++ A0 :: Γ3 ++ # P :: Γ4, C)])
       (Γ0 ++ A :: B → D :: B → D :: x1 ++ # P → A0 :: Γ3 ++ # P :: Γ4, C) H0 d1). auto.
   + repeat destruct s. repeat destruct p ; subst.
      apply list_split_form in e1. destruct e1. repeat destruct s ; repeat destruct p ; subst.
      { inversion e1. }
      { assert (J2: derrec_height x < S (dersrec_height d)). lia.
         assert (J3: derrec_height x = derrec_height x). reflexivity.
         assert (J4: (Γ2 ++ A0 :: ((x0 ++ [ (A  → B) → D]) ++ x2) ++ # P :: Γ4, C) = ((Γ2 ++ A0 :: x0) ++  (A  → B) → D :: x2 ++ # P :: Γ4, C)). repeat rewrite <- app_assoc. auto.
         pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
         assert (AtomImpL2Rule [((Γ2 ++ A0 :: x0) ++ A :: B → D :: B → D :: x2 ++ # P :: Γ4, C)]
         ((Γ2 ++ # P → A0 :: x0) ++ A :: B → D :: B → D :: x2 ++ # P :: Γ4, C)).
         assert ((Γ2 ++ A0 :: x0) ++ A :: B → D :: B → D :: x2 ++ # P :: Γ4 = Γ2 ++ A0 :: (x0 ++ A :: B → D :: B → D :: x2) ++ # P :: Γ4). repeat rewrite <- app_assoc. auto.
         rewrite H0.
         assert ((Γ2 ++ # P → A0 :: x0) ++ A :: B → D :: B → D :: x2 ++ # P  :: Γ4 = Γ2 ++ # P → A0 :: (x0 ++ A :: B → D :: B → D :: x2) ++ # P :: Γ4). repeat rewrite <- app_assoc. auto.
         rewrite H1. apply AtomImpL2Rule_I. apply AtomImpL2 in H0. pose (dlCons d0 DersNilF).
         pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
         (ps:=[((Γ2 ++ A0 :: x0) ++ A :: B → D :: B → D :: x2 ++ # P :: Γ4, C)])
         ((Γ2 ++ # P → A0 :: x0) ++ A :: B → D :: B → D :: x2 ++ # P :: Γ4, C) H0 d1). auto. }
      { repeat destruct s. repeat destruct p ; subst.
         assert (J2: derrec_height x < S (dersrec_height d)). lia.
         assert (J3: derrec_height x = derrec_height x). reflexivity.
         assert (J4: (Γ2 ++ A0 :: Γ3 ++ # P :: x1 ++  (A  → B) → D :: Γ1, C) = ((Γ2 ++ A0 :: Γ3 ++ # P :: x1) ++  (A  → B) → D :: Γ1, C)).
         repeat rewrite <- app_assoc ; simpl ; repeat rewrite <- app_assoc ; auto.
         pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
         assert (AtomImpL2Rule [((Γ2 ++ A0 :: Γ3 ++ # P :: x1) ++ A :: B → D :: B → D :: Γ1, C)]
         ((Γ2 ++ # P → A0 :: Γ3 ++ # P :: x1) ++ A :: B → D :: B → D :: Γ1, C)). repeat rewrite <- app_assoc. simpl. repeat rewrite <- app_assoc.
         apply AtomImpL2Rule_I. apply AtomImpL2 in H0. pose (dlCons d0 DersNilF).
         pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
         (ps:=[((Γ2 ++ A0 :: Γ3 ++ # P :: x1) ++ A :: B → D :: B → D :: Γ1, C)])
         ((Γ2 ++ # P → A0 :: Γ3 ++ # P :: x1) ++ A :: B → D :: B → D :: Γ1, C) H0 d1). auto. }
 (* AndImpL *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
    apply list_split_form in H2. destruct H2. repeat destruct s ; repeat destruct p ; subst.
   + inversion e1.
   +  assert (J2: derrec_height x < S (dersrec_height d)). lia.
       assert (J3: derrec_height x = derrec_height x). reflexivity.
       assert (J4: (((Γ0 ++ [ (A  → B) → D]) ++ x1) ++ A0 → B0 → C0 :: Γ3, C) = (Γ0 ++  (A  → B) → D :: x1 ++ A0 → B0 → C0 :: Γ3, C)). repeat rewrite <- app_assoc. auto.
       pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
       assert (AndImpLRule [((Γ0 ++ A :: B → D :: B → D :: x1) ++ A0 → B0 → C0 :: Γ3, C)]
       ((Γ0 ++ A :: B → D :: B → D :: x1) ++ (A0 ∧ B0) → C0 :: Γ3, C)). apply AndImpLRule_I.
       repeat rewrite <- app_assoc in H0. apply AndImpL in H0.
       pose (dlCons d0 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(Γ0 ++ A :: B → D :: B → D :: x1 ++ A0 → B0 → C0 :: Γ3, C)])
       (Γ0 ++ A :: B → D :: B → D :: x1 ++ (A0 ∧ B0) → C0 :: Γ3, C) H0 d1). auto.
   +  repeat destruct s. repeat destruct p ; subst.
       assert (J2: derrec_height x < S (dersrec_height d)). lia.
       assert (J3: derrec_height x = derrec_height x). reflexivity.
       assert (J4: (Γ2 ++ A0 → B0 → C0 :: x0 ++  (A  → B) → D :: Γ1, C) = ((Γ2 ++ A0 → B0 → C0 :: x0) ++  (A  → B) → D :: Γ1, C)). repeat rewrite <- app_assoc. auto.
       pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
       assert (AndImpLRule [((Γ2 ++ A0 → B0 → C0 :: x0) ++ A :: B → D :: B → D :: Γ1, C)]
       ((Γ2 ++ (A0 ∧ B0) → C0 :: x0) ++ A :: B → D :: B → D :: Γ1, C)). repeat rewrite <- app_assoc. apply AndImpLRule_I.
       apply AndImpL in H0. pose (dlCons d0 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[((Γ2 ++ A0 → B0 → C0 :: x0) ++ A :: B → D :: B → D :: Γ1, C)])
       ((Γ2 ++ (A0 ∧ B0) → C0 :: x0) ++ A :: B → D :: B → D :: Γ1, C) H0 d1). auto.
  (* OrImpL *)
  * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity. simpl.
     pose (@dersrec_derrec_height (dersrec_height d) _ _ _ _ d J30). destruct s.
     apply list_split_form in H2. destruct H2. repeat destruct s ; repeat destruct p ; subst.
   + inversion e1.
   +  assert (J2: derrec_height x < S (dersrec_height d)). lia.
       assert (J3: derrec_height x = derrec_height x). reflexivity.
       assert (J4: (((Γ0 ++ [ (A  → B) → D]) ++ x1) ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4, C) = (Γ0 ++  (A  → B) → D ::  x1 ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4, C)).
       repeat rewrite <- app_assoc. auto.
       pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
       assert (OrImpLRule [((Γ0 ++ A :: B → D :: B → D :: x1) ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4, C)]
       ((Γ0 ++ A :: B → D :: B → D :: x1) ++ (A0 ∨ B0) → C0 :: Γ3 ++ Γ4, C)). apply OrImpLRule_I.
       repeat rewrite <- app_assoc in H0. apply OrImpL in H0.
       pose (dlCons d0 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(Γ0 ++ A :: B → D :: B → D :: x1 ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4, C)])
       (Γ0 ++ A :: B → D :: B → D :: x1 ++ (A0 ∨ B0) → C0 :: Γ3 ++ Γ4, C) H0 d1). auto.
   +  repeat destruct s. repeat destruct p ; subst.
       assert (J50: derrec_height x = derrec_height x). auto.
       assert (J51: list_exch_L (Γ2 ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4, C) (Γ2 ++ A0 → C0 :: B0 → C0 :: x0 ++  (A  → B) → D :: Γ1, C)).
       assert (Γ2 ++ A0 → C0 :: Γ3 ++ B0 → C0 :: Γ4 = (Γ2 ++ [A0 → C0]) ++ [] ++ Γ3 ++ [B0 → C0] ++ Γ4).
       repeat rewrite <- app_assoc. auto. rewrite H0.
       assert (Γ2 ++ A0 → C0 :: B0 → C0 :: x0 ++  (A  → B) → D :: Γ1 = (Γ2 ++ [A0 → C0]) ++ [B0 → C0] ++ Γ3 ++ [] ++ Γ4).
       rewrite <- e1 ; repeat rewrite <- app_assoc ; auto. rewrite H1. apply list_exch_LI.
       pose (GL4ip_hpadm_list_exch_L (derrec_height x) _ x J50 _ J51). destruct s.
       assert (J2: derrec_height x1 < S (dersrec_height d)). lia.
       assert (J3: derrec_height x1 = derrec_height x1). reflexivity.
       assert (J4: (Γ2 ++ A0 → C0 :: B0 → C0 :: x0 ++  (A  → B) → D :: Γ1, C) = ((Γ2 ++ A0 → C0 :: B0 → C0 :: x0) ++  (A  → B) → D :: Γ1, C)). repeat rewrite <- app_assoc. auto.
       pose (IH _ J2 _ x1 _ _ _ _ _ _ J3 J4).
       assert (OrImpLRule [((Γ2 ++ A0 → C0 :: B0 → C0 :: x0) ++ A :: B → D :: B → D :: Γ1, C)]
       ((Γ2 ++ (A0 ∨ B0) → C0 :: x0) ++ A :: B → D :: B → D :: Γ1, C)).
       assert ((Γ2 ++ A0 → C0 :: B0 → C0 :: x0) ++ A :: B → D :: B → D :: Γ1 = Γ2 ++ A0 → C0 :: [] ++ B0 → C0 :: x0 ++ A :: B → D :: B → D :: Γ1).
       repeat rewrite <- app_assoc ; simpl ; repeat rewrite <- app_assoc ; auto. rewrite H0.
       assert ((Γ2 ++ (A0 ∨ B0) → C0 :: x0) ++ A :: B → D :: B → D :: Γ1 = Γ2 ++ (A0 ∨ B0) → C0 :: [] ++ x0 ++ A :: B → D :: B → D :: Γ1).
       repeat rewrite <- app_assoc ; simpl ; repeat rewrite <- app_assoc ; auto. rewrite H1.
       apply OrImpLRule_I.  apply OrImpL in H0. pose (dlCons d0 DersNilF).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[((Γ2 ++ A0 → C0 :: B0 → C0 :: x0) ++ A :: B → D :: B → D :: Γ1, C)])
       ((Γ2 ++ (A0 ∨ B0) → C0 :: x0) ++ A :: B → D :: B → D :: Γ1, C) H0 d1). auto.
  (* ImpImpL *)
 * inversion H. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
    apply list_split_form in H2. destruct H2. repeat destruct s ; repeat destruct p ; subst.
   + inversion e1. subst.
      assert (J1: ImpRRule [(Γ0 ++ A:: B → D :: Γ1, B)] (Γ0 ++ B → D :: Γ1, A → B)). apply ImpRRule_I.
      pose (ImpR_inv _ _ x J1).
      assert (J2: wkn_L (B → D) (Γ0 ++ D :: Γ1, C) (Γ0 ++ B → D :: D :: Γ1, C)). apply wkn_LI.
      pose (GL4ip_adm_wkn_L x0 J2).
      assert (J3: wkn_L A (Γ0 ++ B → D :: D :: Γ1, C) ((Γ0 ++ A :: [B → D]) ++ D :: Γ1, C)). repeat rewrite <- app_assoc. apply wkn_LI.
      pose (GL4ip_adm_wkn_L d1 J3).
      assert (Γ0 ++ A :: B → D :: Γ1 = (Γ0 ++ A :: [B → D]) ++ Γ1). repeat rewrite <- app_assoc ; simpl ; auto. rewrite H0 in d0.
      assert (J4: derrec_height d0 = derrec_height d0). auto.
      assert (J5: ((Γ0 ++ [A; B → D]) ++ Γ1, B) = ((Γ0 ++ [A; B → D]) ++ Γ1, B)). auto.
      pose (ImpL_adm _ _ _ _ _ _ _ _ J4 J5 d2). repeat rewrite <- app_assoc in d3 ; simpl in d3. auto.
   +  assert (J2: derrec_height x < S (dersrec_height d)). lia.
       assert (J3: derrec_height x = derrec_height x). reflexivity.
       assert (J4: (((Γ0 ++ [ (A  → B) → D]) ++ x2) ++ B0 → C0 :: Γ3, A0 → B0) = (Γ0 ++  (A  → B) → D :: x2 ++ B0 → C0 :: Γ3, A0 → B0)).
       repeat rewrite <- app_assoc. auto.
       pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       assert (J7: (((Γ0 ++ [ (A  → B) → D]) ++ x2) ++ C0 :: Γ3, C) = (Γ0 ++  (A  → B) → D :: x2 ++ C0 :: Γ3, C)).
       repeat rewrite <- app_assoc. auto.
       pose (IH _ J5 _ x0 _ _ _ _ _ _ J6 J7).
       assert (ImpImpLRule [((Γ0 ++ A :: B → D :: B → D :: x2) ++ B0 → C0 :: Γ3, A0 → B0);((Γ0 ++ A :: B → D :: B → D :: x2) ++ C0 :: Γ3, C)]
       ((Γ0 ++ A :: B → D :: B → D :: x2) ++ (A0 → B0) → C0 :: Γ3, C)). apply ImpImpLRule_I.
       repeat rewrite <- app_assoc in H0. apply ImpImpL in H0.
       pose (dlCons d1 DersNilF). pose (dlCons d0 d2).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(Γ0 ++ A :: B → D :: B → D :: x2 ++ B0 → C0 :: Γ3, A0 → B0); (Γ0 ++ A :: B → D :: B → D :: x2 ++ C0 :: Γ3, C)])
       (Γ0 ++ A :: B → D :: B → D :: x2 ++ (A0 → B0) → C0 :: Γ3, C) H0 d3). auto.
   +  repeat destruct s. repeat destruct p ; subst.
       assert (J2: derrec_height x < S (dersrec_height d)). lia.
       assert (J3: derrec_height x = derrec_height x). reflexivity.
       assert (J4: (Γ2 ++ B0 → C0 :: x1 ++  (A  → B) → D :: Γ1, A0 → B0) = ((Γ2 ++ B0 → C0 :: x1) ++  (A  → B) → D :: Γ1, A0 → B0)). repeat rewrite <- app_assoc. auto.
       pose (IH _ J2 _ x _ _ _ _ _ _ J3 J4).
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       assert (J7: (Γ2 ++ C0 :: x1 ++  (A  → B) → D :: Γ1, C) = ((Γ2 ++ C0 :: x1) ++  (A  → B) → D :: Γ1, C)).
       repeat rewrite <- app_assoc. auto.
       pose (IH _ J5 _ x0 _ _ _ _ _ _ J6 J7).
       assert (ImpImpLRule [((Γ2 ++ B0 → C0 :: x1) ++ A :: B → D :: B → D :: Γ1, A0 → B0);((Γ2 ++ C0 :: x1) ++ A :: B → D :: B → D :: Γ1, C)]
       ((Γ2 ++ (A0 → B0) → C0 :: x1) ++ A :: B → D :: B → D :: Γ1, C)). repeat rewrite <- app_assoc. apply ImpImpLRule_I.
       apply ImpImpL in H0. pose (dlCons d1 DersNilF). pose (dlCons d0 d2).
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[((Γ2 ++ B0 → C0 :: x1) ++ A :: B → D :: B → D :: Γ1, A0 → B0); ((Γ2 ++ C0 :: x1) ++ A :: B → D :: B → D :: Γ1, C)])
       ((Γ2 ++ (A0 → B0) → C0 :: x1) ++ A :: B → D :: B → D :: Γ1, C) H0 d3). auto.
  (* BoxImpL *)
 * inversion X. subst. assert (J30: dersrec_height d = dersrec_height d). reflexivity.
    pose (@dersrec_derrec2_height (dersrec_height d) _ _ _ _ _ d J30). repeat destruct s. simpl.
    apply univ_gen_ext_splitR in X0. destruct X0. destruct s. repeat destruct p ; subst.
    apply list_split_form in H. destruct H. repeat destruct s ; repeat destruct p ; subst.
   + inversion e1.
   +  apply univ_gen_ext_splitR in u. destruct u. destruct s. repeat destruct p ; subst.
       apply univ_gen_ext_splitR in u. destruct u. destruct s. repeat destruct p ; subst.
       inversion u2. subst. exfalso. assert (In ( (A  → B) → D) (((x1 ++  (A  → B) → D :: l) ++ x5) ++ x2)).
       apply in_or_app ; left ; apply in_or_app ; left ; apply in_or_app ; right ; apply in_eq.
       apply H1 in H. destruct H. inversion H. subst. inversion X0. subst.
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       assert (J7: (((Γ0 ++ [ (A  → B) → D]) ++ x4) ++ B0 :: Γ3, C) = (Γ0 ++  (A  → B) → D :: x4 ++ B0 :: Γ3, C)).
       repeat rewrite <- app_assoc. auto.
       pose (IH _ J5 _ x0 _ _ _ _ _ _ J6 J7).
       assert (BoxImpLRule [(XBoxed_list (x1 ++ (top_boxes [A]) ++ x5 ++ x2) ++ [Box A0], A0);((Γ0 ++ A :: B → D :: B → D :: x4) ++ B0 :: Γ3, C)]
       ((Γ0 ++ A :: B → D :: B → D :: x4) ++ Box A0 → B0 :: Γ3, C)).
       { destruct (dec_is_boxedT A).
          - apply BoxImpLRule_I ; auto. destruct i. subst. simpl. repeat rewrite <- app_assoc in H1 ; simpl in H1.
            intro. intros. apply in_app_or in H. destruct H. apply H1. apply in_or_app ; auto.
            inversion H. subst. exists x3. auto. apply in_app_or in H0 ; destruct H0. apply H1.
            apply in_or_app ; right ; apply in_or_app ; auto. apply H1.
            apply in_or_app ; right ; apply in_or_app ;  auto.
            assert (top_boxes [A] = [A]). destruct i ; subst ; simpl ; auto.
            rewrite H. simpl. repeat rewrite <- app_assoc ; simpl. repeat apply univ_gen_ext_combine ; auto.
            apply univ_gen_ext_cons ; auto. repeat apply univ_gen_ext_extra ; try intro ; try destruct X1 ; try inversion H0 ; auto.
            apply univ_gen_ext_combine ; auto.
          - assert (top_boxes [A] = []).
            destruct A ; auto ; exfalso ; apply f ; exists A ; auto. rewrite H ; auto. simpl.
            apply BoxImpLRule_I ; simpl  ; repeat rewrite <- app_assoc in H1 ; simpl in H1 ; auto.
            rewrite <- app_assoc ; simpl.
            repeat apply univ_gen_ext_combine ; auto. repeat apply univ_gen_ext_extra ; auto.
            intro. destruct X1. inversion H0. intro. destruct X1. inversion H0. apply univ_gen_ext_combine ; auto. }
       assert (existsT2 (D2 : derrec GL4ip_rules (fun _ : Seq => False) (XBoxed_list (x1 ++ top_boxes [A] ++ x5 ++ x2) ++ [Box A0], A0)),
       derrec_height D2 <= derrec_height x).
       { destruct (dec_is_boxedT A).
          - assert (top_boxes [A] = [A]). destruct i. subst ; auto. rewrite H. repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc.
            assert (J1: derrec_height x = derrec_height x). auto.
            pose (@GL4ip_list_wkn_L _ _ _ _ _ J1 (XBoxed_list [A])). destruct s.
            assert (J2: derrec_height x3 = derrec_height x3). auto.
            assert (J3: list_exch_L (XBoxed_list (((x1 ++ []) ++ x5) ++ x2) ++ XBoxed_list [A] ++ [Box A0], A0) (XBoxed_list x1 ++ XBoxed_list [A] ++ XBoxed_list x5 ++ XBoxed_list x2 ++ [Box A0], A0)).
            repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc.
            assert (XBoxed_list x1 ++ XBoxed_list [] ++ XBoxed_list x5 ++ XBoxed_list x2 ++ XBoxed_list [A] ++ [Box A0] = XBoxed_list x1 ++ [] ++ (XBoxed_list x5 ++ XBoxed_list x2) ++ XBoxed_list [A] ++ [Box A0]).
            repeat rewrite <- app_assoc ; simpl ; auto. rewrite H0.
            assert (XBoxed_list x1 ++ XBoxed_list [A] ++ XBoxed_list x5 ++ XBoxed_list x2 ++ [Box A0] = XBoxed_list x1 ++ XBoxed_list [A] ++ (XBoxed_list x5 ++ XBoxed_list x2) ++ [] ++ [Box A0]).
            repeat rewrite <- app_assoc ; simpl ; auto. rewrite H3. apply list_exch_LI.
            pose (GL4ip_hpadm_list_exch_L _ _ _ J2 _ J3). destruct s. exists x6. lia.
          - assert (top_boxes [A] = []).
            destruct A ; auto ; exfalso ; apply f ; exists A ; auto. rewrite H ; auto. simpl.
            assert (x1 ++ x5 ++ x2 = ((x1 ++ []) ++ x5) ++ x2). repeat rewrite <- app_assoc ; simpl ; auto. rewrite H0.
            exists x. lia. }
       destruct X2. apply BoxImpL in X1.
       pose (dlCons d0 DersNilF). pose (dlCons x3 d1). repeat rewrite <- app_assoc in X1.
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(XBoxed_list (x1 ++ top_boxes [A] ++ x5 ++ x2) ++ [Box A0], A0); (Γ0 ++ A :: B → D :: B → D :: x4 ++ B0 :: Γ3, C)])
       (Γ0 ++ A :: B → D :: B → D :: x4 ++ Box A0 → B0 :: Γ3, C) X1 d2). auto.
   +  repeat destruct s. repeat destruct p ; subst.
       apply univ_gen_ext_splitR in u0. destruct u0. destruct s. repeat destruct p ; subst.
       inversion u1. subst. exfalso. assert (In ( (A  → B) → D) (x1 ++ x4 ++  (A  → B) → D :: l)).
       apply in_or_app ; right ; apply in_or_app ; right ; apply in_eq.
       apply H1 in H. destruct H. inversion H. subst.
       assert (J5: derrec_height x0 < S (dersrec_height d)). lia.
       assert (J6: derrec_height x0 = derrec_height x0). reflexivity.
       assert (J7: (Γ2 ++ B0 :: x3 ++  (A  → B) → D :: Γ1, C) = ((Γ2 ++ B0 :: x3) ++  (A  → B) → D :: Γ1, C)).
       repeat rewrite <- app_assoc. auto.
       pose (IH _ J5 _ x0 _ _ _ _ _ _ J6 J7).
       assert (BoxImpLRule [(XBoxed_list (x1 ++ x4 ++ (top_boxes [A]) ++ x5) ++ [Box A0], A0);((Γ2 ++ B0 :: x3) ++ A :: B → D :: B → D :: Γ1, C)]
       ((Γ2 ++ Box A0 → B0 :: x3) ++ A :: B → D :: B → D :: Γ1, C)).
       { destruct (dec_is_boxedT A).
          - repeat rewrite <- app_assoc. simpl. apply BoxImpLRule_I ; auto. destruct i. subst. simpl.
            intro. intros. apply in_app_or in H. destruct H. apply H1. apply in_or_app ; auto.
            apply in_app_or in H ; destruct H. apply H1.
            apply in_or_app ; right ; apply in_or_app ; auto. inversion H. subst. exists x2. auto. apply H1.
            apply in_or_app ; right ; apply in_or_app ;  auto.
            assert (match A with
                     | Box A1 => [Box A1]
                     | _ => []
                     end = [A]). destruct i ; subst ; simpl ; auto.
            rewrite H. simpl. repeat rewrite <- app_assoc ; simpl. repeat apply univ_gen_ext_combine ; auto.
            apply univ_gen_ext_cons ; auto. repeat apply univ_gen_ext_extra ; try intro ; try destruct X1 ; try inversion H0 ; auto.
          - assert (top_boxes [A] = []).
            destruct A ; auto ; exfalso ; apply f ; exists A ; auto. rewrite H ; auto. simpl. repeat rewrite <- app_assoc ; simpl.
            apply BoxImpLRule_I ; simpl  ; repeat rewrite <- app_assoc in H1 ; simpl in H1 ; auto.
            repeat apply univ_gen_ext_combine ; auto. repeat apply univ_gen_ext_extra ; auto.
            intro. destruct X1. inversion H0. intro. destruct X1. inversion H0. }
       assert (existsT2 (D2 : derrec GL4ip_rules (fun _ : Seq => False) (XBoxed_list (x1 ++ x4 ++ top_boxes [A] ++ x5) ++ [Box A0], A0)),
       derrec_height D2 <= derrec_height x).
       { destruct (dec_is_boxedT A).
          - assert (top_boxes [A] = [A]). destruct i. subst ; auto. rewrite H. repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc.
            assert (J1: derrec_height x = derrec_height x). auto.
            pose (@GL4ip_list_wkn_L _ _ _ _ _ J1 (XBoxed_list [A])). destruct s.
            assert (J2: derrec_height x2 = derrec_height x2). auto.
            assert (J3: list_exch_L (XBoxed_list (x1 ++ x4 ++ x5) ++ XBoxed_list [A] ++ [Box A0], A0) (XBoxed_list x1 ++ XBoxed_list x4 ++ XBoxed_list [A] ++ XBoxed_list x5 ++ [Box A0], A0)).
            repeat rewrite XBox_app_distrib. repeat rewrite <- app_assoc.
            assert (XBoxed_list x1 ++ XBoxed_list x4 ++ XBoxed_list x5 ++ XBoxed_list [A] ++ [Box A0] = (XBoxed_list x1 ++ XBoxed_list x4) ++ [] ++ XBoxed_list x5 ++ XBoxed_list [A] ++ [Box A0]).
            repeat rewrite <- app_assoc ; simpl ; auto. rewrite H0.
            assert (XBoxed_list x1 ++ XBoxed_list x4 ++ XBoxed_list [A] ++ XBoxed_list x5 ++ [Box A0] = (XBoxed_list x1 ++ XBoxed_list x4) ++ XBoxed_list [A] ++ XBoxed_list x5 ++ [] ++ [Box A0]).
            repeat rewrite <- app_assoc ; simpl ; auto. rewrite H3. apply list_exch_LI.
            pose (GL4ip_hpadm_list_exch_L _ _ _ J2 _ J3). destruct s. exists x6. lia.
          - assert (top_boxes [A] = []).
            destruct A ; auto ; exfalso ; apply f ; exists A ; auto. rewrite H ; auto. simpl. exists x. lia. }
       destruct X2. apply BoxImpL in X1.
       pose (dlCons d0 DersNilF). pose (dlCons x2 d1). repeat rewrite <- app_assoc in X1. repeat rewrite <- app_assoc. simpl. simpl in X1.
       assert (match A with
                                  | Box A => [Box A]
                                  | _ => []
                                  end = top_boxes [A]). simpl. auto. rewrite H in X1. repeat rewrite <- app_assoc in d2.
       pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
       (ps:=[(XBoxed_list (x1 ++ x4 ++ top_boxes [A] ++ x5) ++ [Box A0], A0); (Γ2 ++ B0 :: x3 ++ A :: B → D :: B → D :: Γ1, C)])
       (Γ2 ++ Box A0 → B0 :: x3 ++ A :: B → D :: B → D :: Γ1, C) X1 d2). auto.
  (* GLR *)
  * inversion X. subst. simpl. apply univ_gen_ext_splitR in X0. destruct X0. destruct s. repeat destruct p ; subst.
    inversion u0. subst. exfalso. assert (In ( (A  → B) → D) (x ++  (A  → B) → D :: l)). apply in_or_app ; right ; apply in_eq.
    apply H1 in H. destruct H. inversion H. subst.
    assert (GLRRule [(XBoxed_list (x ++ x0) ++ [Box A0], A0)] (Γ0 ++ Γ1, Box A0)). apply GLRRule_I ; auto.
    apply univ_gen_ext_combine ; auto. apply GLR in X1.
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : Seq => False)
    (ps:=[(XBoxed_list (x ++ x0) ++ [Box A0], A0)]) (Γ0 ++ Γ1, Box A0) X1 d).
    assert (J1: wkn_L (B → D) (Γ0 ++ Γ1, Box A0) (Γ0 ++ B → D :: Γ1, Box A0)). apply wkn_LI.
    pose (@GL4ip_adm_wkn_L _ d0 _ _ J1).
    assert (J2: wkn_L (B → D) (Γ0 ++ B → D :: Γ1, Box A0) (Γ0 ++ B → D :: B → D :: Γ1, Box A0)). apply wkn_LI.
    pose (@GL4ip_adm_wkn_L _ d1 _ _ J2).
    assert (J3: wkn_L A (Γ0 ++ B → D :: B → D :: Γ1, Box A0) (Γ0 ++ A :: B → D :: B → D :: Γ1, Box A0)). apply wkn_LI.
    pose (@GL4ip_adm_wkn_L _ d2 _ _ J3). auto.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Semantics.
Require Import bedrock2.Syntax.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.WeakestPrecondition.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Word.Bitwidth.
Require Import coqutil.Map.Interface.
Require Import coqutil.Tactics.letexists.
Require Import coqutil.Tactics.Tactics.
Require Import Cava.Util.Tactics.
Local Open Scope Z_scope.

(* Proofs about cmd.while *)

Section Proofs.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Fixpoint repeat_logic_step
           (logic : trace -> mem -> locals ->
                    (trace -> mem -> locals -> Prop) -> Prop)
           (n : nat) post : trace -> mem -> locals -> Prop :=
    match n with
    | O => post
    | S n => fun t m l => logic t m l (repeat_logic_step logic n post)
    end.

  Lemma unroll_while functions conde body t m l
        (iterations : nat)
        (post : trace -> mem -> locals -> Prop) :
    repeat_logic_step
      (fun t m l post =>
         exists cond,
           dexpr m l conde cond
           /\ word.unsigned cond <> 0
           /\ cmd (call functions) body t m l post)
      iterations (fun t m l =>
                    exists cond,
                      dexpr m l conde cond
                      /\ word.unsigned cond = 0
                      /\ post t m l) t m l ->
    cmd (call functions) (cmd.while conde body) t m l post.
  Proof.
    lazymatch goal with
      |- repeat_logic_step ?logic _ ?post _ _ _ -> _ =>
      set (step:=logic);
        set (P:=post)
    end.
    intros. exists nat, lt, (fun i => repeat_logic_step step i P).
    ssplit.
    { exact lt_wf. }
    { eauto. }
    { intro i. destruct i; cbn [repeat_logic_step].
      { (* i=0 case (contradiction) *)
        subst P. repeat straightline.
        eexists; ssplit; eauto; congruence. }
      { (* i <> 0 case *)
        subst step. repeat straightline.
        eexists; ssplit; eauto; try congruence; [ ].
        repeat straightline.
        eapply Proper_cmd; [ apply Proper_call | | eassumption ].
        repeat intro. exists i. ssplit; eauto. } }
  Qed.

  (* This lemma handles conditional statements without breaking the entire
     remainder of the function into two goals *)
  Lemma cond_nosplit functions conde ct cf cnext t m l
        (post post_cond : trace -> mem -> locals -> Prop) :
    cmd (call functions) (cmd.cond conde ct cf) t m l post_cond ->
    (forall t m l, post_cond t m l -> cmd (call functions) cnext t m l post) ->
    cmd (call functions) (cmd.seq (cmd.cond conde ct cf) cnext) t m l post.
  Proof.
    cbn [cmd cmd_body]. intros; logical_simplify.
    eexists; ssplit; intros; eauto; [ | ].
    { eapply Proper_cmd; [ apply Proper_call | | solve [eauto] ].
      repeat intro. eauto. }
    { eapply Proper_cmd; [ apply Proper_call | | solve [eauto] ].
      repeat intro. eauto. }
  Qed.
End Proofs.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import TableWalk.Spec.
Require Import AbsAccessor.Spec.
Require Import TableDataOpsIntro.Specs.data_destroy.
Require Import TableDataOpsIntro.LowSpecs.data_destroy.
Require Import TableDataOpsIntro.RefProof.RefRel.

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

Section Refine.

  Hint Unfold
       table_walk_lock_unlock_spec
       get_wi_g_llt_spec
       get_wi_index_spec
       is_null_spec
       granule_map_spec
       pgte_read_spec
       find_lock_granule_spec
       pgte_write_spec
       granule_put_spec
       granule_memzero_spec
       granule_set_state_spec
       granule_unlock_spec
       buffer_unmap_spec
    .

  Lemma data_destroy_spec_exists:
    forall habd habd'  labd g_rd map_addr res
      (Hspec: data_destroy_spec g_rd map_addr habd = Some (habd', res))
      (Hrel: relate_RData habd labd),
    exists labd', data_destroy_spec0 g_rd map_addr labd = Some (labd', res) /\ relate_RData habd' labd'.
  Proof.
    assert(ne51: 5 <> 1) by (red; intro T; inv T).
    Local Opaque peq ptr_eq.
    intros. destruct Hrel. inv id_rdata. destruct g_rd.
    unfold data_destroy_spec, data_destroy_spec0 in *. simpl.
    unfold table_walk_lock_unlock_spec. simpl. unfold Assertion in *.
    rm_bind Hspec; rm_bind'. simpl in *. repeat simpl_hyp Hspec.
    unfold Assertion; rm_bind'.
    repeat simpl_hyp Hspec.
    hsimpl_hyp Hspec; inv Hspec; extract_prop_dec.
    - repeat destruct_con. simpl_query_oracle. simpl in *.
      match type of Hcond6 with
      | is_gidx ?gidx = true => remember gidx as lv1_gidx eqn:Hlv1_gidx; symmetry in Hlv1_gidx
      end.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      match type of Prop0 with
      | glock ?a @ ?gidx = None => remember gidx as data_gidx eqn:Hdata_gidx; symmetry in Hdata_gidx
      end.
      assert(nez: llt_gidx <> data_gidx) by (bool_rel; red; intro T; rewrite T in *; autounfold in *; omega).
      repeat autounfold in *. simpl in *.
      destruct_if. repeat destruct_con. bool_rel; omega.
      solve_bool_range. grewrite. repeat solve_table_range.
      repeat (try solve_peq; try solve_ptr_eq; simpl). simpl_htarget.
      repeat (grewrite; try simpl_htarget; repeat simpl_field; repeat swap_fields; simpl; repeat solve_table_range).
      repeat (solve_bool_range; grewrite). repeat (rewrite ZMap.gss in * ); simpl in *.
      grewrite. simpl in *. repeat (repeat solve_table_range; solve_bool_range; grewrite).
      repeat (grewrite; try simpl_htarget; repeat simpl_field; repeat swap_fields; simpl).
      solve_bool_range. grewrite. repeat (try solve_peq; try solve_ptr_eq; simpl).
      extract_if. reflexivity. grewrite.
      eexists; split. reflexivity. constructor.
      repeat (try rewrite (zmap_comm _ _ ne51);
              try rewrite (zmap_comm _ _ nez)).
      bool_rel. replace (3 * 72057594037927936) with 216172782113783808 by reflexivity.
      grewrite; rewrite <- Prop0, <- C40.
      repeat (repeat simpl_field; repeat swap_fields; repeat simpl_field; simpl_htarget; simpl).
      reflexivity.
    - repeat destruct_con. simpl_query_oracle. simpl in *. extract_prop_dec.
      match type of Hcond6 with
      | is_gidx ?gidx = true => remember gidx as lv1_gidx eqn:Hlv1_gidx; symmetry in Hlv1_gidx
      end.
      match type of Hcond3 with
      | is_gidx ?gidx = true => remember gidx as lv2_gidx eqn:Hlv2_gidx; symmetry in Hlv2_gidx
      end.
      match type of Hcond0 with
      | is_gidx ?gidx = true => remember gidx as llt_gidx eqn:Hllt_gidx; symmetry in Hllt_gidx
      end.
      repeat autounfold in *. simpl in *.
      destruct_if. repeat destruct_con. bool_rel; omega.
      solve_bool_range. grewrite. repeat solve_table_range.
      repeat (try solve_peq; try solve_ptr_eq; simpl). simpl_htarget.
      repeat (grewrite; try simpl_htarget; repeat simpl_field; repeat swap_fields; simpl; repeat solve_table_range).
      repeat (solve_bool_range; grewrite). repeat (rewrite ZMap.gss in * ); simpl in *.
      grewrite. simpl in *. repeat (repeat solve_table_range; solve_bool_range; grewrite).
      repeat (grewrite; try simpl_htarget; repeat simpl_field; repeat swap_fields; simpl).
      inversion Hspec. clear Hspec. eexists; split.  reflexivity. constructor.
      repeat rewrite (zmap_comm _ _ ne51).
      bool_rel. replace (3 * 72057594037927936) with 216172782113783808 by reflexivity.
      clear H0 H1. grewrite; rewrite <- Prop0, <- C33. repeat simpl_field.
      repeat swap_fields; repeat simpl_field; simpl_htarget; simpl. reflexivity.
    - unfold get_wi_g_llt_spec, is_null_spec; simpl. solve_ptr_eq; simpl.
      autounfold in *; solve_table_range. inv Hspec. eexists; split. reflexivity. constructor.
      reflexivity.
    - unfold get_wi_g_llt_spec, is_null_spec; simpl. solve_ptr_eq; simpl.
      autounfold in *; solve_table_range. inv Hspec. eexists; split. reflexivity. constructor.
      reflexivity.
    - unfold get_wi_g_llt_spec, is_null_spec; simpl. solve_ptr_eq; simpl.
      autounfold in *; solve_table_range. inv Hspec. eexists; split. reflexivity. constructor.
      reflexivity.
  Qed.

End Refine.


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

Local Open Scope Z.
Local Open Scope logic.

Definition object_invariant := list Z -> val -> mpred.

Definition tobject := tptr (Tstruct _object noattr).

Definition reset_spec (instance: object_invariant) :=
  WITH self: val, history: list Z
  PRE [ _self OF tobject]
          PROP ()
          LOCAL (temp _self self)
          SEP (instance history self)
  POST [ tvoid ]
          PROP() LOCAL () SEP(instance nil self).

Definition twiddle_spec (instance: object_invariant) :=
  WITH self: val, i: Z, history: list Z
  PRE [ _self OF tobject, _i OF tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 history <= Int.max_signed / 4)
          LOCAL (temp _self self; temp _i (Vint (Int.repr i)))
          SEP (instance history self)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 history < v <= 2* fold_right Z.add 0 (i::history))
          LOCAL (temp ret_temp (Vint (Int.repr v)))
          SEP(instance (i::history) self).

Definition object_methods (instance: object_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val,
  !! readable_share sh &&
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset,twiddle) mtable.

Lemma object_methods_local_facts: forall instance p,
  object_methods instance p |-- !! isptr p.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.
entailer!.
Qed.
Hint Resolve object_methods_local_facts : saturate_local.

Definition object_mpred (history: list Z) (self: val) : mpred :=
  EX instance: object_invariant, EX mtable: val,
       (object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self*
     instance history self).

Definition foo_invariant : object_invariant :=
  (fun (history: list Z) p =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 history)))) p
      *  malloc_token Ews (Tstruct _foo_object noattr) p).

Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () LOCAL (gvars gv)
    SEP (mem_mgr gv; object_methods foo_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () LOCAL (temp ret_temp p)
     SEP (mem_mgr gv; object_mpred nil p; object_methods foo_invariant (gv _foo_methods)).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog nil gv
  POST [ tint ]
     EX i:Z, PROP(0<=i<=6) LOCAL (temp ret_temp (Vint (Int.repr i))) SEP(TT).

Definition Gprog : funspecs :=   ltac:(with_library prog [
    foo_reset_spec; foo_twiddle_spec; make_foo_spec; main_spec]).

Lemma object_mpred_i:
  forall (history: list Z) (self: val) (instance: object_invariant) (mtable: val),
    object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self *
     instance history self
    |-- object_mpred history self.
Proof.
intros. unfold object_mpred. Exists instance mtable; auto.
Qed.

Lemma body_foo_reset: semax_body Vprog Gprog f_foo_reset foo_reset_spec.
Proof.
unfold foo_reset_spec, foo_invariant, reset_spec.
start_function.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
forward.  (* return; *)
all: unfold withspacer; simpl; entailer!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_twiddle: semax_body Vprog Gprog f_foo_twiddle foo_twiddle_spec.
Proof.
unfold foo_twiddle_spec, foo_invariant, twiddle_spec.
start_function.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
forward.  (* return d+i; *)
simpl.
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!.
Exists (2 * fold_right Z.add 0 history + i).
simpl;
entailer!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!.
Qed.

Lemma split_object_methods:
  forall instance m,
    object_methods instance m |-- object_methods instance m * object_methods instance m.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.

Exists (fst (slice.cleave sh)) reset twiddle.
Exists (snd (slice.cleave sh)) reset twiddle.
rewrite (split_func_ptr' (reset_spec instance) reset) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddle) at 1.
entailer!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

Lemma body_make_foo: semax_body Vprog Gprog f_make_foo make_foo_spec.
Proof.
unfold make_foo_spec.
start_function.
forward_call (Tstruct _foo_object noattr, gv).
   split3; simpl; auto; computable.
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _foo_object noattr) p;
          data_at_ Ews (Tstruct _foo_object noattr) p;
          object_methods foo_invariant (gv _foo_methods))).
*
change (Memory.EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!.
*
forward_call tt.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &foo_methods; *)
forward. (* p->data = 0; *)
forward. (* return (struct object * ) p; *)
Exists p.
unfold object_mpred.
Exists foo_invariant (gv _foo_methods).
sep_apply (split_object_methods foo_invariant (gv _foo_methods)).
unfold foo_invariant at 4.
entailer!.
simpl.
unfold_data_at (field_at _ _ nil _ p).
cancel.
unfold withspacer; simpl.
rewrite !field_at_data_at.
simpl.
apply derives_refl'.
rewrite <- ?sepcon_assoc. (* needed if Archi.ptr64=true *)
rewrite !field_compatible_field_address; auto with field_compatible.
clear - H.
(* TODO: simplify the following proof. *)
destruct p; try contradiction.
destruct H as [AL SZ].
repeat split; auto.
simpl in *; omega.
eapply align_compatible_rec_Tstruct; [reflexivity |].
simpl co_members; intros.
simpl in H.
if_tac in H; [| inv H].
inv H. inv H0.
eapply align_compatible_rec_by_value.
reflexivity.
rewrite Z.add_0_r.
simpl.
unfold natural_alignment in AL.
eapply Z.divide_trans; [ | apply AL].
apply prove_Zdivide.
reflexivity.
left; auto.
Qed.

Lemma make_object_methods:
  forall sh instance reset twiddle mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset, twiddle) mtable
  |-- object_methods instance mtable.
Proof.
  intros.
  unfold object_methods.
  Exists sh reset twiddle.
  entailer!.
Qed.

Ltac method_call witness hist' result :=
repeat apply seq_assoc1;
match goal with
   |- semax _ (PROPx _ (LOCALx ?Q (SEPx ?R)))
            (Ssequence (Sset ?mt (Efield (Ederef (Etempvar ?x _)  _) _ _))
                 _) _  =>
    match Q with context [temp ?x ?x'] =>
     match R with context [object_mpred _ x'] =>
          let instance := fresh "instance" in let mtable := fresh "mtable" in
          unfold object_mpred; Intros instance mtable;
          forward;
          unfold object_methods at 1;
          let sh := fresh "sh" in let r := fresh "r" in let t := fresh "t" in
          Intros sh r t;
          forward;
          forward_call witness;
          [ .. | try Intros result;
                  sep_apply (make_object_methods sh instance r t mtable); [ auto .. | ];
                  sep_apply (object_mpred_i hist' x' instance mtable);
                  deadvars; try clear dependent sh; try clear r; try clear t
           ]
    end end
end.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
(* assert_gvar _foo_methods. (* TODO: this is needed for a field_compatible later on *) *)
fold noattr cc_default.

(* 0. This part should be handled automatically by start_function *)
gather_SEP 1 2;
replace_SEP 0 (data_at Ews (Tstruct _methods noattr)
   (gv _foo_reset, gv _foo_twiddle) (gv _foo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _methods _) _ (gv _foo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite field_at_data_at.  rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  rewrite sepcon_comm.
  apply derives_refl.
}

(* 1. Prove that [mtable] is a proper method-table for foo-objects *)

make_func_ptr _foo_twiddle.
make_func_ptr _foo_reset.
sep_apply (make_object_methods Ews foo_invariant(gv _foo_reset) (gv _foo_twiddle) (gv _foo_methods)); auto.

(* 2. Build an instance of class [foo], called [p] *)
forward_call (* p = make_foo(); *)
        gv.
Intros p.

(* 3. Done with object_methods for the foreseeable future *)
freeze [2]  MT. gather_SEP 1.

(* Illustration of an alternate method to prove the method calls.
   Method 1:  comment out lines AA and BB and the entire range CC-DD.
   Method 2:  comment out lines AA-BB, inclusive.
*)

(* AA *) try (tryif
  (method_call (p, @nil Z) (@nil Z) whatever;
   method_call (p, 3, @nil Z) [3%Z] i;
     [simpl; computable | ])
(* BB *)  then fail else fail 99)
  .

(* CC *)
(* 4. first method-call *)
unfold object_mpred.
Intros instance mtable0.
forward. (*  mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward. (* p_reset = mtable->reset; *)
forward_call (* p_reset(p); *)
      (p, @nil Z).
(* Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).
deadvars!. clear.

(* 5. second method-call *)
unfold object_mpred.
Intros instance mtable0.
forward.  (* mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward.   (* p_twiddle = mtable->twiddle; *)
forward_call (* i = p_twiddle(p,3); *)
      (p, 3, @nil Z).
  simpl. computable.
Intros i.
simpl in H0.
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [3] p instance mtable0).
deadvars!. clear - H0.

(* DD *)

(* 6. return *)
forward.  (* return i; *)
Exists i; entailer!.
Qed.


Require Import Mtac2.Mtac2.
Import T.

Example test_selector1 : forall n, n >= 0.
MProof.
  destructn 0 &> S.first (apply le_0_n).
Abort.

Example test_selector2 : forall n, n >= 0.
MProof.
  destructn 0 &> S.rev &> S.last (apply le_0_n).
Abort.

Example test_selector3 : forall n, n >= 0.
MProof.
  destructn 0 |1> apply le_0_n.
Abort.

Example test_selector4 : forall n, n >= 0.
MProof.
  destructn 0 &> S.rev l> apply le_0_n.
Abort.

Example test_selector5 : forall n, n >= 0.
MProof.
  destructn 0 &> S.rev |2> apply le_0_n.
Abort.

Example test_selector6 : forall n, n >= 0.
MProof.
  (destructn 0 &> S.rev |2> apply le_0_n) |1> idtac.
Abort.

Example test_selector7 : forall n, n >= 0.
MProof.
  Fail (destructn 0 &> S.rev |2> apply le_0_n) |2> print_goal.
Abort.


Require Import CoRN.reals.fast.CRtrans.

Extraction Language Haskell.

Extract Inductive bool => Bool [ True False ].
Extract Inductive option => Maybe [ Just Nothing ].

Extract Inductive list => "([])" [ "[]" "( : )" ].
Extract Inlined Constant List.tl => "tail".
Extract Inlined Constant List.hd => "head".
Extract Inlined Constant List.map => "map".

Extract Inductive CoqStreams.Stream => "([])" ["( : )"].
Extract Inlined Constant CoqStreams.tl => "tail".
Extract Inlined Constant CoqStreams.hd => "head".
Extract Inlined Constant CoqStreams.map => "map".
Extract Inlined Constant CoqStreams.zipWith => "zipWith".

Extract Inductive sum => "( :+: )" [ "Inl" "Inr" ].

Extract Inductive prod => "( , )" [ "( , )" ].
Extract Inlined Constant fst => "fst".
Extract Inlined Constant snd => "snd".

Extract Inductive sumbool => Bool [ True False ].
Extraction Inline sumbool_rec.

Extract Inductive comparison => Ordering [ EQ LT GT ].

(* Misc *)
Extraction Inline eq_rect.
Extraction Inline eq_rec.
Extraction Inline eq_rec_r.
Extraction Inline proj1_sig.

(* nat *)
Extract Inductive nat => Integer [ "0" "succ" ]
 "(\ fO fS n -> if n == 0 then fO () else fS (n - 1))".

Extract Inlined Constant plus => "(+)".
Extract Inlined Constant pred => "fun n -> max 0 (pred n)".
Extract Inlined Constant minus => "fun n m -> max 0 (n - m)".
Extract Inlined Constant mult => "(*)".
Extract Inlined Constant max => max.
Extract Inlined Constant min => min.
Extract Inlined Constant EqNat.beq_nat => "(==)".
Extract Inlined Constant EqNat.eq_nat_decide => "(==)".
Extract Inlined Constant Peano_dec.eq_nat_dec => "(==)".

(* ZArith *)
Extract Inductive positive => Integer [ "(\p -> 1+2*p)" "(\p -> 2*p)" "1" ]
 "(\f2p1 f2p f1 p -> if p <= 1 then f1 () else if p`mod` 2 == 0 then f2p (p `div` 2) else f2p1 (p `div` 2))".

Extract Inductive Z => Integer [ "0" "" "negate" ]
"(\f0 fp fn z -> if z == 0 then f0 () else if z > 0 then fp z else fn (negate z))".

Extract Inlined Constant Pplus => "(+)".
Extract Inlined Constant Pos.succ => "succ".
Extract Inlined Constant Pos.pred => "pred".
Extract Inlined Constant Pminus => "\n m -> max 1 (n - m)".
Extract Inlined Constant Pmult => "(*)".
Extract Inlined Constant Pos.min => "min".
Extract Inlined Constant Pos.max => "max".
(* Probably a change in the way Coq handles numbers, ask PL.
Extract Inlined Constant Pcompare => "compare".*)
Extract Inlined Constant positive_eq_dec => "(==)".
Extraction Inline positive_rec.

Extract Inlined Constant Zplus => "(+)".
Extract Inlined Constant Z.succ => "succ".
Extract Inlined Constant Z.pred => "pred".
Extract Inlined Constant Zminus => "(-)".
Extract Inlined Constant Zmult => "(*)".
Extract Inlined Constant Z.opp => "negate".
Extract Inlined Constant Z.abs => "abs".
Extract Inlined Constant Z.min => "min".
Extract Inlined Constant Z.max => "max".
Extract Inlined Constant Z.compare => "compare".
Extract Inlined Constant Z.eq_dec => "(==)".
Extraction Inline Z_rec.
Extract Inlined Constant Z_of_nat => "id".

(* QArith *)
Extract Inductive Q => Rational [ "( :% )" ].
Extract Inlined Constant Qnum => "numerator".
Extract Inlined Constant Qden => "denominator".

Extract Inlined Constant Qplus => "(+)".
Extract Inlined Constant Qplus' => "(+)".
Extract Inlined Constant Qopp => "negate".
Extract Inlined Constant QMinMax.Qmin => "min".
Extract Inlined Constant Qminus' => "min".
Extract Inlined Constant QMinMax.Qmax => "max".
Extract Inlined Constant Qmult => "(*)".
Extract Inlined Constant Qmult' => "(*)".
Extract Inlined Constant Qinv => "recip".
Extract Inlined Constant Qcompare => "compare".
Extract Inlined Constant inject_Z => "fromInteger".
Extract Inlined Constant Qeq_dec => "(==)".

(*
Definition answer (n:positive) (r:CR) : Z :=
 let m := (iter_pos n _ (Pmult 10) 1%positive) in
 let (a,b) := (approximate r (1#m)%Qpos)*m in
 Zdiv a b.

Definition test := answer 10 (exp ('1))%CR.

Recursive Extraction test.
*)