Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import VST.msl.sepalg.
Require Import VST.msl.sepalg_generators.
Require Import VST.msl.age_sepalg.
Require Import VST.msl.predicates_hered.
Require Import VST.msl.predicates_sl.
Require Import VST.msl.subtypes.

Local Open Scope pred.

Lemma unfash_derives {A} `{agA : ageable A}:
  forall {P Q}, (P |-- Q) -> @derives A _ (! P) (! Q).
Proof.
intros. intros w ?. simpl in *. apply H. auto.
Qed.

Lemma subp_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall G P P' Q Q',
  G |-- P >=> P' ->
  G |-- Q >=> Q' ->
  G |-- P * Q >=> P' * Q'.
Proof.
  pose proof I.
  repeat intro.
  specialize (H0 _ H2).
  specialize (H1 _ H2).
  clear G H2.
  destruct H5 as [w1 [w2 [? [? ?]]]].
  exists w1; exists w2; split; auto.
  split.
  eapply H0; auto.
  assert (level w1 = level a').
  apply comparable_fashionR.  eapply join_sub_comparable; eauto.
 apply necR_level in H4. omega.
  eapply H1; auto.
  assert (level w2 = level a').
  apply comparable_fashionR. eapply join_sub_comparable; eauto.
 apply necR_level in H4. omega.
Qed.

Lemma sub_wand {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall G P P' Q Q',
  G |-- P' >=> P ->
  G |-- Q >=> Q' ->
  G |-- (P -* Q) >=> (P' -* Q').
Proof.
  pose proof I.
  repeat intro.
  specialize (H0 _ H2); specialize (H1 _ H2); clear G H2; pose (H2:=True).
  eapply H0 in H8; try apply necR_refl.
  eapply H1; try apply necR_refl.
  apply necR_level in H4. apply necR_level in H6. apply join_comparable in H7.
  apply comparable_fashionR in H7. unfold fashionR in H7. omega.
  eapply H5; eauto.
  apply necR_level in H4. apply necR_level in H6.
   apply join_comparable2 in H7.
  apply comparable_fashionR in H7. unfold fashionR in H7. omega.
Qed.

Lemma find_superprecise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
   forall Q, Q |-- EX P:_, P && !(P >=> Q) && !!superprecise (P).
Proof.
intros.
intros w ?.
exists (exactly w).
split; auto.
split; auto.
hnf; apply necR_refl.
intros w' ? w'' ? ?.
hnf in H2.
apply pred_nec_hereditary with w; auto.
do 3 red.
apply superprecise_exactly.
Qed.

Lemma sepcon_subp' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall (P P' Q Q' : pred A) (st: nat),
    (P >=> P') st ->
    (Q >=> Q') st ->
    (P * Q >=> P' * Q') st.
Proof.
 pose proof I.
intros.
intros w' ? w'' ? [w1 [w2 [? [? ?]]]].
destruct (nec_join4 _ _ _ _ H4 H3) as [w1' [w2' [? [? ?]]]].
exists w1; exists w2; repeat split; auto.
eapply (H0 w1'); eauto.
simpl in *.
subst.
replace (level w1') with (level w'); auto.
symmetry; apply comparable_fashionR; eapply join_comparable; eauto.
eapply (H1 w2'); eauto.
replace (level w2') with (level w'); auto.
symmetry. apply comparable_fashionR.
eapply join_comparable; eauto.
Qed.

Lemma subp_refl'  {A} `{agA : ageable A} :  forall (Q: pred A) (st: nat), (Q >=> Q) st.
Proof.
intros.
intros ? ? ? ?; auto.
Qed.

Lemma subp_trans' {A} `{agA : ageable A}:
  forall (B C D: pred A) (w: nat), (B >=> C)%pred w -> (C >=> D)% pred w -> (B >=> D)%pred w.
Proof.
intros.
intros w' ? w'' ? ?.
eapply H0; eauto.
eapply H; eauto.
Qed.

Lemma andp_subp'  {A} `{agA : ageable A} :
 forall (P P' Q Q': pred A) (w: nat), (P >=> P') w -> (Q >=> Q') w -> (P && Q >=> P' && Q') w.
Proof.
intros.
intros w' ? w'' ? [? ?]; split.
eapply H; eauto.
eapply H0; eauto.
Qed.

Lemma allp_subp' {A} `{agA : ageable A}: forall T (F G: T -> pred A) (w: nat),
   (forall x,  (F x >=> G x) w) -> (allp (fun x:T => (F x >=> G x)) w).
Proof.
intros.
intro x; apply H; auto.
Qed.

Lemma pred_eq_e1 {A} `{agA : ageable A}: forall (P Q: pred A) w,
       ((P <=> Q) w -> (P >=> Q) w).
Proof.
intros.
intros w' ? w'' ? ?.
eapply H; eauto.
Qed.

Lemma pred_eq_e2 {A} `{agA : ageable A}: forall (P Q: pred A)  w,
     ((P <=> Q) w -> (Q >=> P) w).
Proof.
Proof.
intros.
intros w' ? w'' ? ?.
eapply H; eauto.
Qed.

Hint Resolve @sepcon_subp'.
Hint Resolve @subp_refl'.
Hint Resolve @andp_subp'.
Hint Resolve @allp_subp'.
Hint Resolve @derives_subp.
Hint Resolve @pred_eq_e1.
Hint Resolve @pred_eq_e2.

Lemma allp_imp2_later_e2 {B}{A}{agA: ageable A}:
   forall (P Q: B -> pred A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> Q y >=> |> P y.
Proof.
  intros.  intros w ?. specialize (H y). apply pred_eq_e2. auto.
Qed.
Lemma allp_imp2_later_e1 {B}{A}{agA: ageable A}:
   forall (P Q: B -> pred A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> P y >=> |> Q y.
Proof.
  intros.  intros w ?. specialize (H y). apply pred_eq_e1. auto.
Qed.

(*
Lemma subp_later {A} `{agA:  ageable A} (SS: natty A):
 forall (P Q: pred A), |> (P >=> Q) |-- |> P >=> |> Q.
Proof.
intros.
rewrite later_fash; auto.
apply fash_derives.
apply axiomK.
Qed.
*)

Lemma extend_unfash {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P: pred nat), boxy extendM (! P).
Proof.
intros.
apply boxy_i; auto; intros.
unfold unfash in *.
simpl in H. destruct H.
hnf in H0|-*.
replace (level w') with (level w); auto.
apply comparable_fashionR.
eapply join_comparable; eauto.
Qed.

Hint Resolve @extend_unfash.

Lemma subp_unfash {A} `{Age_alg A}:
  forall (P Q : pred nat) (n: nat), (P >=> Q) n -> ( ! P >=> ! Q) n.
Proof.
intros.
intros w ?. specialize (H0 _ H1).
intros w' ? ?. apply (H0 _ (necR_level' H2)).
auto.
Qed.
Hint Resolve @subp_unfash.

Lemma unfash_sepcon_distrib:
        forall {T}{agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T}
           (P: pred nat) (Q R: pred T),
               unfash P && (Q*R) = (unfash P && Q) * (unfash P && R).
Proof.
intros.
apply pred_ext.
intros w [? [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; repeat split; auto.
apply join_level in H0. destruct H0.
hnf in H|-*. congruence.
apply join_level in H0. destruct H0.
hnf in H|-*. congruence.
intros w [w1 [w2 [? [[? ?] [? ?]]]]].
split.
apply join_level in H. destruct H.
hnf in H0|-*. congruence.
exists w1; exists w2; repeat split; auto.
Qed.


Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.
Require Import VST.floyd.fieldlist.
Require Import VST.floyd.type_induction.
Require Import VST.floyd.nested_pred_lemmas.
Open Scope Z.

Module Type ACR_DEC.

  Parameter align_compatible_rec_dec:
    forall {cs: compspecs},
      forall t z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.

End ACR_DEC.

Module align_compatible_rec_dec: ACR_DEC.

Section align_compatible_rec_dec.

Context {cs: compspecs}.

Definition dec_type := sigT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}).

Definition dec_by_value (ch: memory_chunk): dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => (Memdata.align_chunk ch | z)) (fun z => Zdivide_dec (Memdata.align_chunk ch) z (Memdata.align_chunk_pos _)).

Definition dec_False: dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => False) (fun z => right (fun H => H)).

Definition dec_True: dec_type :=
  existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => True) (fun z => left I).
(*
Definition dec_aux_struct_field (denv: PTree.t dec_type) (i: positive) (m: members): dec_type :=
  match field_type i m, field_offset cenv_cs i m with
  | Errors.OK t, Errors.OK ofs => existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => projT1 (dec_aux denv t) (z + ofs)) (fun z => projT2 (dec_aux denv t) (z + ofs))
  | _, _ => dec_False
  end.

Definition dec_aux_union_field (denv: PTree.t dec_type) (i: positive) (m: members): dec_type :=
  match field_type i m with
  | Errors.OK t => dec_aux denv t
  | _ => dec_False
  end.

Fixpoint dec_aux_struct_composite (denv: PTree.t dec_type) (m_rec m: members): dec_type :=
  match m_rec with
  | nil => dec_True
  | (i, _) :: m_rec' => existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => projT1 (dec_aux_struct_field denv i m) z /\ projT1 (dec_aux_struct_composite denv m_rec' m) z) (fun z => sumbool_dec_and (projT2 (dec_aux_struct_field denv i m) z) (projT2 (dec_aux_struct_composite denv m_rec' m) z))
  end.

Fixpoint dec_aux_union_composite (denv: PTree.t dec_type) (m_rec m: members): dec_type :=
  match m_rec with
  | nil => dec_True
  | (i, _) :: m_rec' => existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => projT1 (dec_aux_union_field denv i m) z /\ projT1 (dec_aux_union_composite denv m_rec' m) z) (fun z => sumbool_dec_and (projT2 (dec_aux_union_field denv i m) z) (projT2 (dec_aux_union_composite denv m_rec' m) z))
  end.

Definition dec_aux: type -> dec_type.
  refine (type_func (fun _ => dec_type) _ _ _ _).
  + intro t.
    exact (match access_mode t with
           | By_value ch => dec_by_value ch
           | _ => dec_False
           end).
  + intros t' n _ d.
    exact (existT (fun P: Z -> Prop => forall z: Z, {P z} + {~ P z}) (fun z => forall i, 0 <= i < n -> projT1 d (z + sizeof t' * i)) (fun z => Zrange_pred_dec (fun i => projT1 d (z + sizeof t' * i)) (fun i => projT2 d (z + sizeof t' * i)) 0 n)).
  + intros id _ D.
    unfold FT_aux in D.

Definition dec_aux_composite (denv: PTree.t dec_type) (su: struct_or_union) (m: members): dec_type :=
  match su with
  | Struct => dec_aux_struct_composite denv m m
  | Union => dec_aux_union_composite denv m m
  end.

Definition dec_aux_env : PTree.t dec_type :=
  let l := composite_reorder.rebuild_composite_elements cenv in
  fold_right (fun (ic: positive * composite) (T0: PTree.t dec_type) => let (i, co) := ic in let T := T0 in PTree.set i (dec_aux_composite T (co_su co) (co_members co)) T) (PTree.empty _) l.

 *)

Lemma align_compatible_rec_dec: forall t z, {align_compatible_rec cenv_cs t z} + {~ align_compatible_rec cenv_cs t z}.
Admitted.

End align_compatible_rec_dec.

End align_compatible_rec_dec.

Lemma align_compatible_dec: forall {cs: compspecs} t p, {align_compatible t p} + {~ align_compatible t p}.
Proof.
  intros.
  destruct p; try solve [left; unfold align_compatible; simpl; tauto].
  simpl.
  apply align_compatible_rec_dec.align_compatible_rec_dec.
Qed.


Require Import null_listat1_spec.

Definition type_LF_155 :=  PLAN ->  nat ->  nat ->  nat -> (Prop * (List.list term)).

Definition F_155 : type_LF_155:= (fun   u1 u2 _ _ => (u1 = Nil -> (listAt u1 u2) = Nil, (model_PLAN u1)::(Term id_Nil nil)::(Term id_listAt ((model_PLAN u1):: (model_nat u2)::nil))::(Term id_Nil nil)::nil)).
Definition F_167 : type_LF_155:= (fun    _  _ _ _ => (Nil = Nil -> Nil = Nil, (Term id_Nil nil)::(Term id_Nil nil)::(Term id_Nil nil)::(Term id_Nil nil)::nil)).
Definition F_173 : type_LF_155:= (fun   u5 u2 u6 u7 => ((Cons (C u6 u7) u5) = Nil -> (le (time (C u6 u7)) u2) = true -> (Cons (C u6 u7) u5) = Nil, (Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u7)::nil)):: (model_PLAN u5)::nil))::(Term id_Nil nil)::(Term id_le ((Term id_time ((Term id_C ((model_nat u6):: (model_nat u7)::nil))::nil)):: (model_nat u2)::nil))::(Term id_true nil)::(Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u7)::nil)):: (model_PLAN u5)::nil))::(Term id_Nil nil)::nil)).
Definition F_179 : type_LF_155:= (fun   u5 u2 u6 u7 => ((Cons (C u6 u7) u5) = Nil -> (le (time (C u6 u7)) u2) = false -> (listAt u5 u2) = Nil, (Term id_Cons ((Term id_C ((model_nat u6):: (model_nat u7)::nil)):: (model_PLAN u5)::nil))::(Term id_Nil nil)::(Term id_le ((Term id_time ((Term id_C ((model_nat u6):: (model_nat u7)::nil))::nil)):: (model_nat u2)::nil))::(Term id_false nil)::(Term id_listAt ((model_PLAN u5):: (model_nat u2)::nil))::(Term id_Nil nil)::nil)).

Definition LF_155 := [F_155, F_167, F_173, F_179].

Function f_155 (u1: PLAN) (u2: nat) {struct u1} : PLAN :=
 match u1, u2 with
| Nil, _ => Nil
| (Cons (C u6 u7) u5), _ => Nil
end.

Lemma main_155 : forall F, In F LF_155 -> forall u1, forall u2, forall u3, forall u4, (forall F', In F' LF_155 -> forall e1, forall e2, forall e3, forall e4, less (snd (F' e1 e2 e3 e4)) (snd (F u1 u2 u3 u4)) -> fst (F' e1 e2 e3 e4)) -> fst (F u1 u2 u3 u4).
Proof.
intros F HF u1 u2 u3 u4; case_In HF; intro Hind.

	(* GENERATE on [ 155 ] *)

rename u1 into _u1. rename u2 into _u2. rename u3 into d_u3. rename u4 into d_u4.
rename _u1 into u1. rename _u2 into u2.

revert Hind.

pattern u1, u2, (f_155 u1 u2). apply f_155_ind.

(* case [ 167 ] *)

intros _u1 _u2.  intro eq_1. intro. intro Heq2. rewrite <- Heq2.  intro HFabs0.
assert (Hind := HFabs0 F_167). clear HFabs0.
assert (HFabs0 : fst (F_167 Nil 0 0 0)).
apply Hind. trivial_in 1. unfold snd. unfold F_167. unfold F_155. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_155. unfold F_167.
auto.

intros _u1 _u2. intro u6. intro u7. intro u5.  intro eq_1. intro. intro Heq2. rewrite <- Heq2.  intro HFabs0.
case_eq (le (time (C u6 u7)) _u2); [intro H | intro H].

(* case [ 173 ] *)

assert (Hind := HFabs0 F_173). clear HFabs0.
assert (HFabs0 : fst (F_173 u5 _u2 u6 u7)).
apply Hind. trivial_in 2. unfold snd. unfold F_173. unfold F_155. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_155. unfold F_173. simpl in H. repeat(simpl; rewrite H). repeat(simpl in HFabs0; rewrite H in HFabs0). try (auto || (intro H0; contradict H0)).
auto.

(* case [ 179 ] *)

assert (Hind := HFabs0 F_179). clear HFabs0.
assert (HFabs0 : fst (F_179 u5 _u2 u6 u7)).
apply Hind. trivial_in 3. unfold snd. unfold F_179. unfold F_155. rewrite_model. abstract solve_rpo_mul.
unfold fst. unfold F_155. unfold F_179. simpl in H. repeat(simpl; rewrite H). repeat(simpl in HFabs0; rewrite H in HFabs0). try (auto || (intro H0; contradict H0)).
auto.

	(* TAUTOLOGY on [ 167 ] *)

unfold fst. unfold F_167.
auto.

	(* TAUTOLOGY on [ 173 ] *)

unfold fst. unfold F_173.
auto.

	(* NEGATIVE CLASH on [ 179 ] *)

unfold fst. unfold F_179. intros. try discriminate.

Qed.

(* the set of all formula instances from the proof *)
Definition S_155 := fun f => exists F, In F LF_155 /\ exists e1, exists e2, exists e3, exists e4, f = F e1 e2 e3 e4.

Theorem all_true_155: forall F, In F LF_155 -> forall u1: PLAN, forall u2: nat, forall u3: nat, forall u4: nat, fst (F u1 u2  u3  u4).
Proof.
let n := constr:(4) in
let p := constr:(S(S(n))) in
intros;
let G := fresh "G" in
let x := fresh "x" in
apply wf_subset with (R:=@snd_rpo_mul P Prop max_size) (S:=S_155);
[(* 1 *) apply wf_snd_rpo_mul, prec_wf
|(* 2 *) idtac
|(* 3 *) eexists; split; [ eassumption | idtac]; do_nat n ltac:(eexists); reflexivity
];

intros x G;
do_nat p ltac:(elim G; intro; clear G; intro G);
rewrite G in * |- *; clear G; clear x;
intro G;
apply main_155;
 [assumption | idtac];
intros;
apply G;
 [ idtac | assumption ];
eexists; split;
 [idtac | do_nat n ltac:(eexists); reflexivity];
assumption.
Qed.

Theorem true_155: forall (u1: PLAN) (u2: nat), u1 = Nil -> (listAt u1 u2) = Nil.
Proof.
do 2 intro.
apply (all_true_155 F_155);
 (trivial_in 0) ||
 (repeat constructor).
Qed.


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Export type_sys_useful.
Require Export etype_family.
Require Import dest_close.

Lemma close_type_system_isect :
  forall (ts : candidate-type-system)
         T T'
         (eq : per)
         A A' v v' B B' eqa eqa' eqb
         f f' g g',
    type_system ts
    -> defines_only_universes ts
    -> computes_to_valc T (mkc_eisect A v B)
    -> computes_to_valc T' (mkc_eisect A' v' B')
    -> close ts A A eqa
    -> close ts A' A' eqa'
    -> (forall (a : CTerm) (e : eqa a a),
          close ts (substc a v B) (substc (f a e) v' B') (eqb a (f a e) e (g a e)))
    -> (forall (a : CTerm) (e : eqa a a),
          type_system ts
          -> defines_only_universes ts
          -> type_sys_props (close ts) (substc a v B) (substc (f a e) v' B')
                            (eqb a (f a e) e (g a e)))
    -> (forall (a' : CTerm) (e' : eqa' a' a'),
          close ts (substc (f' a' e') v B) (substc a' v' B') (eqb (f' a' e') a' (g' a' e') e'))
    -> (forall (a' : CTerm) (e' : eqa' a' a'),
          type_system ts
          -> defines_only_universes ts
          -> type_sys_props (close ts) (substc (f' a' e') v B) (substc a' v' B')
                            (eqb (f' a' e') a' (g' a' e') e'))
    -> (eq <=2=> (eisect_eq eqa eqa' eqb))
    -> per_eisect (close ts) T T' eq
    -> type_sys_props (close ts) A A eqa
    -> type_sys_props (close ts) A' A' eqa'
    -> type_sys_props (close ts) T T' eq.
Proof.
  introv tysys dou c1 c2 cla cla' clb tspb clb' tspb'.
  introv eqiff perTT' IHa IHa'.

  rw type_sys_props_iff_type_sys_props2.
  prove_type_sys_props2 SCase; intros.

  + SCase "uniquely_valued".
    dclose cl cl; dclose_lr.

    * SSCase "CL_isect".
      allunfold per_eisect; exrepd.
      apply eq_term_equals_trans with (eq2 := eisect_eq eqa0 eqa'0 eqb0);
        try (complete (apply eq_term_equals_sym; auto)).
      apply eq_term_equals_trans with (eq2 := eisect_eq eqa eqa' eqb); auto.

XXXXXXXXXX

      generalize (eq_term_equals_type_family T T3 eqa0 eqa eqb0 eqb (close ts) A v B A' v' B' mkc_isect); intro i.
      repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))); repnd.

      unfold eq_term_equals; sp.
      rw t0; rw eqiff; split; sp.

      duplicate e as e'; rw <- i0 in e.
      generalize (i1 a a' e' e); intro k.
      rw k; sp.

      duplicate e as e'; rw i0 in e.
      generalize (i1 a a' e e'); intro k.
      rw <- k; sp.

    * SSCase "CL_isect".
      allunfold per_isect; exrepd.
      generalize (eq_term_equals_type_family T' T3 eqa0 eqa eqb0 eqb (close ts) A' v' B' A v B mkc_isect); intro i.
      repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))); repnd.
      apply type_sys_props_sym; sp.
      onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
      intros.
      apply type_sys_props_sym.
      apply type_sys_props_eqb_comm; sp.
      apply tet with (t2 := a'); sp.
      apply tet with (t2 := a); sp.

      unfold eq_term_equals; sp.
      rw t0; rw eqiff; split; sp.

      duplicate e as e'; rw <- i0 in e.
      generalize (i1 a a' e' e); intro k.
      rw k; sp.

      duplicate e as e'; rw i0 in e.
      generalize (i1 a a' e e'); intro k.
      rw <- k; sp.

  + SCase "type_symmetric"; repdors; subst; dclose_lr;
    apply CL_isect;
    clear per;
    allunfold per_isect; exrepd;
    unfold per_isect;
    exists eqa0 eqb0; sp;
    allrw <-; sp.

  + SCase "type_value_respecting"; repdors; subst;
    apply CL_isect; unfold per_isect; exists eqa eqb; sp.

    duplicate c1 as ct.
    apply cequivc_mkc_isect with (T' := T3) in ct; sp.

    apply type_family_cequivc
          with
          (A1 := A)
          (v1 := v)
          (B1 := B)
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A')
          (v := v')
          (B := B'); sp.

    duplicate c2 as ct.
    apply cequivc_mkc_isect with (T' := T3) in ct; sp.

    apply type_family_cequivc2
          with
          (A1 := A')
          (v1 := v')
          (B1 := B')
          (A2 := A'0)
          (v2 := v'0)
          (B2 := B'0)
          (A := A)
          (v := v)
          (B := B); sp.

  + SCase "term_symmetric".
    unfold term_equality_symmetric; sp.
    onedtsp e p p0 p1 c t t0 t3 tygs tygt dum.
    apply eqiff; sp.
    assert (eqa a a) as eqaa by (apply t0 with (t2 := a'); auto).
    assert (eqa a' a) as e' by auto.
    assert (eq t1 t2) as eq12 by auto.
    apply eqiff with (a := a') (a' := a) (e := e') in eq12; auto.

    generalize (eq_term_equals_sym_tsp (close ts) eqa eqb a a' eqaa e0 e'
                                       v B v' B'); intro i.
    autodimp i h; repnd.

    (* Now we prove the equality between the applies *)
    unfold eq_term_equals in i.
    apply i in eq12.
    generalize (recb a a' e0); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.

  + SCase "term_transitive".
    unfold term_equality_transitive; sp.
    apply eqiff; sp.
    assert (eq t1 t2) as eq12 by auto.
    assert (eq t2 t3) as eq23 by auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eq12; auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eq23; auto.

    onedtsp IHX0 IHX2 IHX3 IHX4 IHX5 IHX6 IHX7 IHX8 tygs tygt dum.

    generalize (recb a a' e); intro tsp.
    unfold type_sys_props in tsp; sp.
    apply tsp6 with (t2 := t2); auto.

  + SCase "term_value_respecting".
    unfold term_equality_respecting; sp.
    apply eqiff; sp.
    assert (eq t t) as eqtt by auto.
    apply eqiff with (a := a) (a' := a') (e := e) in eqtt; auto.

    generalize (recb a a' e); sp.
    onedtsp X5 X6 X7 X8 X9 X10 X11 X4 tygs1 tygt1 dum1; sp.

  + SCase "type_gsymmetric"; repdors; subst; split; sp; dclose_lr;
    apply CL_isect;
    clear per;
    allunfold per_isect; exrepd.

    (* 1 *)
    generalize (eq_term_equals_type_family
                  T T3 eqa0 eqa eqb0 eqb (close ts)
                  A v B A' v' B' mkc_isect); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    unfold per_isect.
    exists eqa eqb; sp.

    rw t0; split; intro k; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

    (* 2 *)
    generalize (eq_term_equals_type_family2
                  T3 T eqa0 eqa eqb0 eqb (close ts)
                  A v B A' v' B' mkc_isect); intro i;
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp)));
    repnd.

    unfold per_isect.
    exists eqa eqb; sp.

    rw t0; split; intro k; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

    (* 3 *)
    generalize (eq_term_equals_type_family
                  T' T3 eqa0 eqa eqb0 eqb (close ts)
                  A' v' B' A v B mkc_isect); intro i.
    repeat (autodimp i hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    unfold per_isect.
    exists eqa eqb; sp.

    rw t0; split; intro k; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

    (* 4 *)
    generalize (eq_term_equals_type_family2
                  T3 T' eqa0 eqa eqb0 eqb (close ts)
                  A' v' B' A v B mkc_isect); intro i;
    repeat (autodimp i hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    unfold per_isect.
    exists eqa eqb; sp.

    rw t0; split; intro k; sp.

    duplicate e as e'.
    rw i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e e'); intro eqt.
    rw eqt in j; sp.

    duplicate e as e'.
    rw <- i0 in e.
    generalize (k a a' e); intro j.
    generalize (i1 a a' e' e); intro eqt.
    rw <- eqt in j; sp.

  + SCase "type_gtransitive"; sp.

  + SCase "type_mtransitive".
    repdors; subst; dclose_lr;
    try (move_term_to_top (per_isect (close ts) T T4 eq2));
    try (move_term_to_top (per_isect (close ts) T' T4 eq2)).

    (* 1 *)
    clear per.
    allunfold per_isect; exrepd.

    generalize (eq_term_equals_type_family2
                  T3 T eqa1 eqa eqb1 eqb (close ts)
                  A v B A' v' B' mkc_isect); intro i.
    repeat (autodimp i hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    generalize (type_family_trans2
                  mkc_isect (close ts) T3 T T4 eqa eqb eqa0 eqb0 A v B A' v' B'); intro j.
    repeat (autodimp j hyp; try (complete (introv e; eqconstr e; sp))).
    repnd.

    dands; apply CL_isect; unfold per_isect; exists eqa eqb; sp; allrw.

    split; intro p; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (p a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (p a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.

    split; intro p; sp.

    assert (eqa0 a a') as e' by (rw <- j0; auto).
    generalize (p a a' e'); intro k.
    generalize (j1 a a' e e'); intro l.
    rw l; sp.

    assert (eqa a a') as e' by (rw j0; auto).
    generalize (p a a' e'); intro k.
    generalize (j1 a a' e' e); intro l.
    rw <- l; sp.

    split; intro p; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (p a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (p a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.

    (* 2 *)
    clear per.
    allunfold per_isect; exrepd.

    generalize (eq_term_equals_type_family2
                  T3 T' eqa1 eqa eqb1 eqb (close ts)
                  A' v' B' A v B mkc_isect); intro i.
    repeat (autodimp i hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    generalize (type_family_trans2
                  mkc_isect (close ts) T3 T' T4 eqa eqb eqa0 eqb0 A' v' B' A v B); intro j.
    repeat (autodimp j hyp;
            try (complete (introv e; eqconstr e; sp));
            try (complete (apply type_sys_props_sym; sp))).
    onedtsp uv tys tyt tyst tyvr tes tet tevr tygs tygt dum.
    intros.
    apply type_sys_props_sym.
    apply type_sys_props_eqb_comm; sp.
    apply tet with (t2 := a'); sp.
    apply tet with (t2 := a); sp.
    repnd.

    dands; apply CL_isect; unfold per_isect; exists eqa eqb; sp; allrw.

    split; intro p; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (p a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (p a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.

    split; intro p; sp.

    assert (eqa0 a a') as e' by (rw <- j0; auto).
    generalize (p a a' e'); intro k.
    generalize (j1 a a' e e'); intro l.
    rw l; sp.

    assert (eqa a a') as e' by (rw j0; auto).
    generalize (p a a' e'); intro k.
    generalize (j1 a a' e' e); intro l.
    rw <- l; sp.

    split; intro p; sp.

    assert (eqa1 a a') as e' by (rw <- i0; auto).
    generalize (p a a' e'); intro k.
    generalize (i1 a a' e' e); intro l.
    rw <- l; sp.

    assert (eqa a a') as e' by (rw i0; auto).
    generalize (p a a' e'); intro k.
    generalize (i1 a a' e e'); intro l.
    rw l; sp.
Qed.


From isla Require Import opsem.

Definition a24 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 13%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x13" [] (RegVal_Base (Val_Symbolic 13%Z)) Mk_annot :t:
  Smt (DefineConst 14%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 13%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "x18" [] (RegVal_Base (Val_Symbolic 14%Z)) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.


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 _ : (list (MPropF V)) *(MPropF V)  => 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 _ : (list (MPropF V)) *(MPropF V) => False)
    (ps:=[]) (x ++ # P :: x0, # P) H1 DersNilF). auto.
  (* BotL *)
  * inversion H. subst. assert (InT (Bot V) (Γ0 ++  (A  → B) → D :: Γ1)).
    rewrite <- H2. apply InT_or_app. right. apply InT_eq. assert (InT (Bot V) (Γ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 ++ Bot V :: x0, C)). apply BotLRule_I. apply BotL in H1.
    pose (derI (rules:=GL4ip_rules) (prems:=fun _ : (list (MPropF V)) *(MPropF V) => False)
    (ps:=[]) (x ++ Bot V :: 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : list (MPropF V) * MPropF V => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : list (MPropF V) * MPropF V => 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 _ : (list (MPropF V)) *(MPropF V) => 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 _ : (list (MPropF V)) *(MPropF V) => 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.


From Parsec Require Export
     Parser.
From ExtLib Require Export
     Extras.
From JSON Require Export
     Jpath.
From Coq Require Export
     ssr.ssrfun.
From AsyncTest Require Export
     Trace
     Common.
Export
  FunNotation.
Open Scope parser_scope.

Inductive jexp :=
  Jexp__Const  : IR                               -> jexp
| Jexp__Array  : list jexp                        -> jexp
| Jexp__Object : list (string * jexp)             -> jexp
| Jexp__Ref    : labelT -> jpath -> (IR -> IR)       -> jexp.

Definition nth_weak (n : nat) (j : IR)
  : option IR :=
  if j is JSON__Array l then
    get_nth n j <|> last (map Some l) None
  else None.

Fixpoint jget_weak (p : jpath) (j : IR) : option IR :=
  match p with
  | Jpath__This        => Some j
  | Jpath__Array  p' n => jget_weak p' j >>= nth_weak n
  | Jpath__Object p' s => jget_weak p' j >>= get_json' s
  end.

Example tget_strong (l : labelT) (p : jpath) (t : traceT) : IR :=
  odflt (JSON__Object []) $ packet__payload <$> get l t >>= jget p.

Definition tget_weak' (jget : jpath -> IR -> option IR)
           (l : labelT) (p : jpath) (t : traceT) : IR :=
  odflt (last (pick_some $ map (jget p ∘ packet__payload ∘ snd) t) $ JSON__Object []) $
        packet__payload <$> get l t >>= jget p.

Definition tget_weak : labelT -> jpath -> traceT -> IR := tget_weak' jget_weak.

Fixpoint jexp_to_IR' (tget : labelT -> jpath -> traceT -> IR)
         (t : traceT) (e : jexp) : IR :=
  match e with
  | Jexp__Const  j => j
  | Jexp__Array  l => JSON__Array  $ map     (jexp_to_IR' tget t) l
  | Jexp__Object m => JSON__Object $ map_snd (jexp_to_IR' tget t) m
  | Jexp__Ref  l p f => f $ tget l p t
  end.

Example jexp_to_IR_strong : traceT -> jexp -> IR := jexp_to_IR' tget_strong.

Definition jexp_to_IR_weak : traceT -> jexp -> IR := jexp_to_IR' tget_weak.

Definition findpath' (p : jpath) : traceT -> list labelT :=
  fmap fst ∘ filter (fun lj => if jget_weak p (packet__payload $ snd lj) is Some _
                          then true else false).

Definition findpath (p : jpath) (f : IR -> IR) (t : traceT) : list jexp :=
  l <- findpath' p t;; [Jexp__Ref l p f].

Fixpoint IR_to_jexp (j : IR) : jexp :=
  match j with
  | JSON__Array l  => Jexp__Array  (map     IR_to_jexp l)
  | JSON__Object l => Jexp__Object (map_snd IR_to_jexp l)
  | _            => Jexp__Const   j
  end.

Fixpoint normalise (e : jexp) : jexp :=
  match e with
  | Jexp__Const  j => IR_to_jexp  j
  | Jexp__Array  l => Jexp__Array  (map     normalise l)
  | Jexp__Object l => Jexp__Object (map_snd normalise l)
  | _            => e
  end.


(** This file was written by Colm Bhandal, PhD student, Foundations and Methods group,
School of Computer Science and Statistics, Trinity College, Dublin, Ireland.*)

Require Import ComhCoq.Extras.LibTactics.

Require Import ComhCoq.LanguageFoundations.
Require Import ComhCoq.ComhBasics.
Require Import ComhCoq.GenTacs.
Require Import ComhCoq.StandardResults.

(***************** Timed lists *****************)

(** A timed element is a vector of base values, along with a timestamp.*)
Record TimedEl : Type := mkTimedEl
{
  msg : list BaseType;
  stamp : Time
}.
Notation "<( m , t )>" := (mkTimedEl m t) (at level 40).

(** Equality is decidable on timed elements.*)
Lemma eqDecTimedEl : eqDec TimedEl. unfold eqDec.
  destruct x1, x2. addHyp (eqDecTime stamp0 stamp1).
  invertClear H. addHyp (list_eq_dec eqDecBase msg0 msg1).
  invertClear H. left. subst. reflexivity. right.
  unfold not. intros. apply H1. inversion H. reflexivity.
  right. unfold not. intros. apply H0. inversion H. reflexivity.
  Qed.

(** A timed list is a list of timed elements.*)
Definition TimedList : Type := list TimedEl.

(**An action is either a delay, an input or an output.*)
Inductive ActTimedList :=
  | atlDel :> Delay -> ActTimedList
  | atlIn : list BaseType -> ActTimedList
  | atlOut : list BaseType -> ActTimedList.

Notation "v ?? " := (atlIn v) (at level 30).
Notation "v !! " := (atlOut v) (at level 30).

Reserved Notation "l -tl- a -tl> l'" (at level 75).

(** The operational semantics for timed lists. Note that the law "buff" will have
to be defined separately for each of the sub-type lists individually,
because it is parametrised on a time T.*)
Inductive stepTimedList : TimedList -> ActTimedList -> TimedList -> Prop :=
  (** If the head of the list has timed out (zero time) then it can be output.*)
  | stepTlFwdHd : forall (v : list BaseType) (l : TimedList),
    <(v, zeroTime)> :: l -tl- v!! -tl> l
  (** If the tail can evolve by outputting an element, then the whole list can evolve as
  such.*)
  | stepTlFwd : forall (l l' : TimedList) (v1 : list BaseType) (e : TimedEl),
    l -tl- v1!! -tl> l' -> e :: l -tl- v1!! -tl> e :: l'
  (** The empty list can delay by any amount and stay as the empty list.*)
  | stepTlDelEmp : forall d : Delay, [] -tl- d -tl> []
  (** If the tail can delay by d, and the timestamp on the head is t + d, then the
  whole list evolves by the tail delaying and the head element timestap reducing to t.
  Note that this differs slightly from the formulation on paper, which asserts that the
  timestamp of the head element is t >= d, and then the resulting timestamp is t - d.
  The reason for this alternative formulation is to avoid subtraction of delays/times.*)
  | stepTlDel : forall (l l' : TimedList) (d : Delay) (v : list BaseType) (t t' : Time),
    l -tl- d -tl> l' -> t = t' +dt+ d -> <(v, t)> :: l -tl- d -tl>
    <(v, t')> :: l'
  where "l -tl- a -tl> l'" := (stepTimedList l a l').

(** The delay action preserves the size of a timed list.*)
Lemma delPresSizeTL : forall (l l' : TimedList) (d : Delay),
  l -tl- d -tl> l' -> length l = length l'. intros.
  remember (atlDel d) as a. induction H. inversion Heqa.
  apply IHstepTimedList in Heqa. simpl. rewrite Heqa. reflexivity.
  reflexivity. apply IHstepTimedList in Heqa. simpl.
  rewrite Heqa. reflexivity. Qed.

(** If [] delays to l', then l' = []*)
Lemma empLeftDelTL : forall (l' : TimedList) (d : Delay),
  [] -tl- d -tl> l' -> l' = []. intros. apply delPresSizeTL in H.
  destruct l'. reflexivity. inversion H. Qed.

(** If l delays to [], then l = []*)
Lemma empRightDelTL : forall (l : TimedList) (d : Delay),
  l -tl- d -tl> [] -> l = []. intros. apply delPresSizeTL in H.
  destruct l. reflexivity. inversion H. Qed.

(** If a timed list l can delay by d to l' which in turn can delay by d' to l'',
then l can delay by d+d' to l''.*)
Lemma delAddTL : forall (l l' l'' : TimedList) (d d' : Delay),
  l -tl- d -tl> l' -> l' -tl- d' -tl> l'' ->
  l -tl- d +d+ d' -tl> l''. induction l; intros.
  erewrite empLeftDelTL. constructor. assert (l' = []).
  eapply empLeftDelTL. apply H. rewrite H1 in H0. apply H0.
  destruct a. destruct l'. apply empRightDelTL in H. inversion H.
  rename t into a. destruct a. inversion H. destruct l''.
  apply empRightDelTL in H0. inversion H0.
  destruct t0. inversion H0. rewrite H18 in H9.
  rewrite delTimeAddAssoc in H9. rewrite timeDelAddSwitch in H9.
  rewrite addDelayComm in H9. rewrite H9. constructor.
  eapply IHl. apply H3. assumption. reflexivity. Qed.

Lemma timedList_timeout_enabled v l :
  <( v, zeroTime )> _: l -> exists l', l -tl- v !! -tl> l'.
  introz U. induction l; inversion U. subst.
  exists l. constructor. apply IHl in H.
  ex_flat. eexists. eapply stepTlFwd. eassumption. Qed.

Lemma timedList_del_le l l' d v t q :
   l -tl- atlDel d -tl> l' -> <( v, t )> _: l ->
  <( v, minusTime t d q )> _: l'. Admitted.

(***************** Input, Output & Notification lists *****************)
(*These will be syntactically the same as timed lists, with the exception of
a wrapper. Each will then diverege in their extension of the semantics of timed lists:
lifting the timed list relation and then adding some new laws specific to the type of list
(input, output or notification).*)

Reserved Notation "l -il- a -il> l'" (at level 75).
Reserved Notation "l -ol- a -ol> l'" (at level 75).
Reserved Notation "l -nl- a -nl> l'" (at level 75).

(** Syntactially, an input list is essentially a timed list.*)
Record InputList : Type := mkInputList {inList : TimedList}.

(** Syntactially, an input list is essentially a timed list.*)
Record OutputList : Type := mkOutputList {outList : TimedList}.

(** Syntactially, an input list is essentially a timed list.*)
Record NotifList : Type := mkNotifList {notifList : TimedList}.

(** Semantics for the input list.*)
Inductive stepInputList : InputList -> ActTimedList -> InputList -> Prop :=
  (** Buffer a message and stamp it with zero time.*)
  | stepIlBuff : forall (l : TimedList) (v : list BaseType),
    mkInputList l -il- v ?? -il> mkInputList (<(v, zeroTime)> :: l)
  (** Delay causes all the messages in the list to be lost. In other words,
  any list can delay and become the empty list.*)
  | stepIlDel : forall (l : InputList) (d : Delay),
    l -il- d -il> mkInputList []
  (** Lift the timed list semantics to these specialised semantics.*)
  | stepIlLift : forall (l l' : TimedList) (a : ActTimedList),
    l -tl- a -tl> l' -> mkInputList l -il- a -il> mkInputList l'
  where "l -il- a -il> l'" := (stepInputList l a l').

Open Scope nat_scope.

(** The size of a list is non-increasing for an input list.*)
Lemma delNonIncSizeIL : forall (l l' : InputList) (d : Delay),
  l -il- d -il> l' -> length (inList l') <= length (inList l).
  intros. inversion H. simpl. apply le_0_n.
  apply delPresSizeTL in H0. simpl. rewrite H0.
  constructor. Qed.

(** If an input list l can delay by d to l' which in turn can delay by d' to l'',
then l can delay by d+d' to l''.*)
Lemma delAddInput : forall (l l' l'' : InputList) (d d' : Delay),
  l -il- d -il> l' -> l' -il- d' -il> l'' ->
  l -il- d +d+ d' -il> l''. intros. destruct l''.
  destruct inList0. constructor. rename t into a.
  destruct l'. destruct inList1. apply delNonIncSizeIL in H0.
  inversion H0. rename t into b. destruct l. destruct inList2.
  apply delNonIncSizeIL in H. inversion H. rename t into c.
  inversion H. inversion H0.
  constructor. eapply delAddTL. apply H4. assumption. Qed.

(** An input list l is action enabled for the action a iff
there is some derivative list l' such that l transitions to l' via a.*)
Definition actEnabledInList (l : InputList) (a : ActTimedList) : Prop :=
  exists l', l -il- a -il> l'.

(** An input list can always input a message.*)
Lemma inListInEnabled : forall (l : InputList) (v : list BaseType),
  actEnabledInList l (v??). intros. destruct l as [l].
  exists (mkInputList (<(v, zeroTime)> :: l)). constructor. Qed.

(**Semantics for the output list.*)
Inductive stepOutputList : OutputList -> ActTimedList -> OutputList -> Prop :=
  (** Buffer a message and stamp it with a timestamp of msgLatency.*)
  | stepOlBuff : forall (l : TimedList) (v : list BaseType),
    mkOutputList l -ol- v?? -ol> mkOutputList (<(v, msgLatency)> :: l)
  (** Lift the timed list semantics to these specialised semantics.*)
  | stepOlLift : forall (l l' : TimedList) (a : ActTimedList),
    l -tl- a -tl> l' -> mkOutputList l -ol- a -ol> mkOutputList l'
  where "l -ol- a -ol> l'" := (stepOutputList l a l').

Lemma delAddOutput : forall (l l' l'' : OutputList) (d d' : Delay),
  l -ol- d -ol> l' -> l' -ol- d' -ol> l'' ->
  l -ol- d +d+ d' -ol> l''. intros. inversion H.
  rewrite <- H4 in H0. inversion H0. constructor.
  eapply delAddTL. apply H1. assumption. Qed.

(**Semantics for the notification list.*)
Inductive stepNotifList : NotifList -> ActTimedList -> NotifList -> Prop :=
  (** Buffer a message and stamp it with a timestamp of adaptNotif.*)
  | stepNlBuff : forall (l : TimedList) (v : list BaseType),
    mkNotifList l -nl- v?? -nl> mkNotifList (<(v, adaptNotif)> :: l)
  (** If the tail can delay to some l', and the head has timed out, then the whole
  list can delay to l', essentially dropping the head.*)
  | stepNlDrop : forall (l : TimedList) (l' : NotifList)
    (d : Delay) (v : list BaseType), mkNotifList l -nl- d -nl> l' ->
    mkNotifList (<(v, zeroTime)> :: l) -nl- d -nl> l'
  | stepNlDelAdd : forall (l l' l'' : NotifList) (d d' : Delay),
    l -nl- d -nl> l' -> l' -nl- d' -nl> l'' ->
    l -nl- (d +d+ d') -nl> l''
  (** Lift the timed list semantics to these specialised semantics.*)
  | stepNlLift : forall (l l' : TimedList) (a : ActTimedList),
    l -tl- a -tl> l' -> mkNotifList l -nl- a -nl> mkNotifList l'
  where "l -nl- a -nl> l'" := (stepNotifList l a l').

  Open Scope R_scope.

Lemma notifList_del_le ln ln' d v t q :
  ln -nl- atlDel d -nl> ln' -> <( v, t )> _: notifList ln ->
  <( v, minusTime t d q )> _: notifList ln'. introz U.
  (*Proof: Induction on the proof of the delay of the notifList.*)
  remember (atlDel d). generalize dependent d.
  generalize dependent t. induction U; intros t U0 d2 q EQ; subst.
  (*Eliminate the input case, which is clearly contradictory to the delay.*)
  inversion EQ.
  (*Next case follows by induction and the fact that t is positive.*)
  apply IHU. inversion U0. inversion H.
  clear IHU. rewrite <- H2 in q. false. eapply Rle_not_lt.
  apply q. delPos. assumption. assumption.
  (*The additive case also follows by induction. We basically thread
  one inductive case to the other.*)
  inversion EQ. generalize dependent q. rewrite <- H0.
  intro q. clear EQ H0.
  assert (atlDel d = atlDel d) as EQD; [ reflexivity |].
  assert (atlDel d' = atlDel d') as EQD'; [ reflexivity |].
  assert (d <= t) as DLE. eapply Rle_trans; [ | apply q].
  simpl. Rplus_le_tac. apply Rlt_le. delPos.
  lets IH1 : IHU1 U0 DLE EQD.
  assert (d' <= minusTime t d DLE) as DLE'. simpl.
  apply Rplus_le_swap_lr. rewrite Rplus_comm. apply q.
  lets IH2 : IHU2 IH1 DLE' EQD'. my_applys_eq IH2.
  f_equal. apply timeEqR. simpl. ring.
  (*Finally we have the lifting case, in which case we lift a similar
  (analogous) result for timed lists.*)
  eapply timedList_del_le; eassumption. Qed.

Lemma timeSplit_inputList l l'' (d d' d'' : Delay) :
  l -il- d'' -il> l'' -> d'' = d +d+ d' ->
  exists l', l -il- d -il> l' /\ l' -il- d' -il> l''.
  Admitted. (*#timeSplit-timedList*)

Lemma timeSplit_outputList l l'' (d d' d''  : Delay) :
  l -ol- d'' -ol> l'' -> d'' = d +d+ d' ->
  exists l', l -ol- d -ol> l' /\ l' -ol- d' -ol> l''.
  Admitted. (*#timeSplit-timedList*)

Lemma timeSplit_notifList l l'' (d d' d''  : Delay) :
  l -nl- d'' -nl> l'' -> d'' = d +d+ d' ->
  exists l', l -nl- d -nl> l' /\ l' -nl- d' -nl> l''.
  Admitted. (*#timeSplit-timedList*)

(***************** Interface Syntax & Semantics *****************)

Record Interface : Type := mkInterface
{
  li : InputList;
  lo : OutputList;
  ln : NotifList
}.

(** Equality is decidable on interfaces.*)
Lemma eqDecInterface : eqDec Interface.
  unfold eqDec. destruct x1, x2.
  destruct li0, lo0, ln0, li1, lo1, ln1.
  addHyp (list_eq_dec eqDecTimedEl inList0 inList1).
  addHyp (list_eq_dec eqDecTimedEl outList0 outList1).
  addHyp (list_eq_dec eqDecTimedEl notifList0 notifList1).
  invertClear H. invertClear H0. invertClear H1. left.
  subst. reflexivity. right. unfold not. intros.
  apply H0. invertClear H1. reflexivity. right. unfold not.
  intros. apply H. invertClear H0. reflexivity. right.
  unfold not. intros. apply H2. invertClear H. reflexivity.
  Qed.

(** Actions for the interface semantics. We have delay, input of a list of base values
on a channel, output of the same, and finally output of a list of base values on a
channel augmented with coverage information.*)
Inductive ActInter :=
  | aiDel :> Delay -> ActInter
  | aiIn : Channel -> list BaseType -> ActInter
  | aiOut : Channel -> list BaseType -> ActInter
  (** The final parameter is the coverage.*)
  | aiOutCov : Channel -> list BaseType -> Distance -> ActInter.

Notation "c !I!" := (aiOut c []) (at level 30).
Notation "c {? v" := (aiIn c v) (at level 30).
Notation "c {! v" := (aiOut c v) (at level 30).
Notation "c _! v !_ r" := (aiOutCov c v r) (at level 30).

Reserved Notation "i -i- a -i> i'" (at level 75).

(** The semantics for the interface.*)
Inductive stepInter : Interface -> ActInter -> Interface -> Prop :=
  | stepIntDel : forall (l1 l1': InputList) (l2 l2': OutputList)
    (l3 l3' : NotifList) (d : Delay), l1 -il- d -il> l1' ->
    l2 -ol- d -ol> l2' -> l3 -nl- d -nl> l3' ->
    (mkInterface l1 l2 l3) -i- d -i> (mkInterface l1' l2' l3')
  | stepIntBuffIn : forall (l1 l1': InputList) (l2 : OutputList)
    (l3 : NotifList) (v : list BaseType), l1 -il- v?? -il> l1' ->
    (mkInterface l1 l2 l3) -i- chanIOEnv {? v -i> (mkInterface l1' l2 l3)
  | stepIntFwdIn : forall (l1 l1': InputList) (l2 : OutputList)
    (l3 : NotifList) (v : list BaseType), l1 -il- v!! -il> l1' ->
    (mkInterface l1 l2 l3) -i- chanInProc {! v -i> (mkInterface l1' l2 l3)
  | stepIntBuffOut : forall (l1 : InputList) (l2 l2' : OutputList)
    (l3 : NotifList) (v : list BaseType), l2 -ol- v?? -ol> l2' ->
    (mkInterface l1 l2 l3) -i- chanOutProc {? v -i> (mkInterface l1 l2' l3)
  | stepIntFwdOut : forall (l1 : InputList) (l2 l2' : OutputList)
    (l3 l3' : NotifList) (v : list BaseType) (r : Distance),
    l2 -ol- v!! -ol> l2' -> l3 -nl- ((baseDistance r) :: v) ?? -nl> l3' ->
    (mkInterface l1 l2 l3) -i- chanIOEnv _! v !_ r -i> (mkInterface l1 l2' l3')
  | stepIntFwdNotif : forall (l1 : InputList) (l2 : OutputList)
    (l3 l3' : NotifList) (v : list BaseType), l3 -nl- v!! -nl> l3' ->
    (mkInterface l1 l2 l3) -i- chanAN {! v -i> (mkInterface l1 l2 l3')
  where "i -i- a -i> i'" := (stepInter i a i').

(** An interface i is action enabled for the action a iff
there is some derivative interface i' such that i transitions to i' via a.*)
Definition actEnabledInter (i : Interface) (a : ActInter) : Prop :=
  exists i', i -i- a -i> i'.

(** incomingInter v i means v is in the incoming list of the interface i.*)
Inductive incomingInter (v : list BaseType) : Interface -> Prop :=
  iciWitness (li : InputList) (lo : OutputList) (ln : NotifList) :
  <( v, zeroTime )> _: inList li ->
  incomingInter v (mkInterface li lo ln).

(** An interface is enabled on a discrete action if it can perform a corresponding
action. The actions in question can be input or output, but there will be no case
for tau because interfaces can't do a tau action.*)
Inductive discActEnabledInter : DiscAct -> Interface -> Prop :=
  | daeiIn : forall (c : Channel) (v : list BaseType) (i i' : Interface),
    i -i- c {? v -i> i' -> discActEnabledInter (c ;? v) i
  | daeiOut : forall (c : Channel) (v : list BaseType) (i i' : Interface),
    i -i- c {! v -i> i' -> discActEnabledInter (c ;! v) i.

(***************** Results *****************)

(** An interface is always enabled on an input on the channel chanIOEnv.*)
Theorem interfaceInEnabled : forall (i : Interface) (v : list BaseType),
  actEnabledInter i (chanIOEnv {? v). destruct i. intros.
  addHyp (inListInEnabled li0 v). invertClear H. rename x into l'.
  exists ({| li := l'; lo := lo0; ln := ln0 |}). constructor.
  assumption. Qed.

Lemma delAddInter : forall (i i' i'' : Interface) (d d' : Delay),
  i -i- d -i> i' -> i' -i- d' -i> i'' ->
  i -i- d +d+ d' -i> i''. destruct i as [l1 l2 l3]. intros.
  destruct i' as [l1' l2' l3']. destruct i'' as [l1'' l2'' l3''].
  invertClear H. invertClear H0. constructor.
  eapply delAddInput. apply H6. assumption.
  eapply delAddOutput. apply H9. assumption.
  eapply stepNlDelAdd. apply H10. assumption. Qed.

Conjecture outList_received_in : forall (l l' : OutputList) (v : list BaseType),
  l -ol- v ?? -ol> l' -> <(v, msgLatency)> _: outList l'.
(**Proof: Obvious from outList semantics*)

Conjecture inList_received_in : forall (l l' : InputList) (v : list BaseType),
  l -il- v ?? -il> l' -> <(v, msgLatency)> _: inList l'.
(**Proof: Obvious from inList semantics*)

Conjecture notifList_received_in : forall (l l' : NotifList) (v : list BaseType),
  l -nl- v ?? -nl> l' -> <(v, msgLatency)> _: notifList l'.
(**Proof: Obvious from notifList semantics*)

(*LOCAL TIDY*)

Lemma inList_pres_input v l l' a :
  <( v, zeroTime )> _: inList l -> l -il- a -il> l' ->
  <( v, zeroTime )> _: inList l' \/ a = v !!. Admitted. (*5*)

(*-LOCAL TIDY*)

(*If the interface component does a step, and there's some timed out message in the input
list, then that message is either still there, or the action was an output of the value in
question on the input channel for the software component.*)
Lemma inList_inter_pres_input v lix lox lnx lix' lox' lnx' a :
  (forall d, a <> aiDel d) -> <(v, zeroTime )> _: inList lix ->
  mkInterface lix lox lnx -i- a -i> mkInterface lix' lox' lnx' ->
  <(v, zeroTime )> _: inList lix' \/
  a = chanInProc{! v. intros.
  (*Proof: Case analyse the interface transition.*)
  inversion H1;
  (*In most of the remaining cases, the input list is preserved, giving the LHS.
  The only cases in which itis not preserved is if an element is buffered or if an
  element leaves the list.*)
  try (subst; left; assumption).
  (*Delay contradicts one of our hypotheses.*)
  false.
  (*Finally we just use an auxiliary result on inList to prove the remaining
  cases.*)
  lets IPI : inList_pres_input H0 H6. elim_intro IPI IL VEQ;
  [left | right; inversion VEQ]; assumption.
  lets IPI : inList_pres_input H0 H6. elim_intro IPI IL VEQ;
  [left | right; inversion VEQ]. assumption. reflexivity.
  Qed.

Lemma timeSplit_inter (h h'' : Interface) (d d' d'' : Delay) :
  h -i- d'' -i> h'' -> d'' = d +d+ d' ->
  exists h', h -i- d -i> h' /\ h' -i- d' -i> h''.
  (*Proof: Follows from time-split results on timed lists*)
  intros. inversion H.
  lets TSI : timeSplit_inputList H2 H0.
  lets TSO : timeSplit_outputList H3 H0.
  lets TSN : timeSplit_notifList H5 H0.
  ex_flat. or_flat. and_flat.
  exists ({| li := x1; lo := x0; ln := x |}).
  split; constructor; eassumption. Qed.

(*A notification list with a timed-out element can output that element.*)
Lemma notif_timeout_enabled_aux v lnx :
  <( v, zeroTime )> _: notifList lnx ->
  exists lnx', lnx -nl- (v !!) -nl> lnx'.
  (*Proof: Lift a more general result on timed lists*)
  introz U. lets TTE : timedList_timeout_enabled U.
  ex_flat. destruct lnx. simpl in H. eexists.
  econstructor. eassumption. Qed.

Lemma notif_timeout_enabled v lix lox lnx :
  <( v, zeroTime )> _: notifList lnx ->
  discActEnabledInter (chanAN ;! v) (mkInterface lix lox lnx).
  (*Proof: Follows from the timeout rule of timed lists
  and the interface semantics.*)
  introz U.
  (*First thing is that we show the transition is possible on the
  notification list.*)
  assert (exists lnx', lnx -nl- (v !!) -nl> lnx') as EXL.
  apply notif_timeout_enabled_aux; assumption. ex_flat.
  eapply daeiOut. eapply stepIntFwdNotif. eassumption.
  Qed.

(*LOCAL TIDY*)

Lemma interface_outProc_in (h : Interface) (v : list BaseType) :
  discActEnabledInter (chanOutProc ;? v) h.
  (*Proof: Obvious from semantics*)
  destruct h. destruct lo0. repeat econstructor. Qed.

Lemma inter_mStable_in_not h h' : h -i- chanMStable {! [] -i> h' -> False.
  introz U. inversion U. Qed.

Lemma inter_abort_in_not h h' :
  h -i- chanAbort {?[] -i> h' -> False.
  introz U. inversion U. Qed.

Lemma outList_in_input_pres v u t lo lo' :
  <( v, t )> _: outList lo -> outList lo -tl- u ?? -tl> outList lo' ->
  <( v, t )> _: outList lo'. Admitted. (*6*)
(*Prove in bulk: #interface-linking*)

Lemma outList_in_output_pres v u t lo lo' :
  <( v, t )> _: outList lo -> outList lo -tl- u !! -tl> outList lo' ->
  0 < t -> <( v, t )> _: outList lo'. Admitted. (*6*)
(*Prove in bulk: #interface-linking*)

(*-LOCAL TIDY*)