(* -------------------------------------------------------------------- *)
(* Copyright (c) - 2015--2016 - IMDEA Software Institute                *)
(* Copyright (c) - 2015--2018 - Inria                                   *)
(* Copyright (c) - 2016--2018 - Polytechnique                           *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
Require Import mathcomp.bigenough.bigenough.
From mathcomp.classical Require Import boolp classical_sets functions.
From mathcomp.classical Require Import mathcomp_extra.
Require Import xfinmap ereal reals discrete topology.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Import Order.TTheory GRing.Theory Num.Theory BigEnough.

Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Notation "f '<=1' g" := (forall x, f x <= g x)
  (at level 70, no associativity).

Notation "f '<=2' g" := (forall x y, f x y <= g x y)
  (at level 70, no associativity).

(* -------------------------------------------------------------------- *)
Section FFTheory.
Context {R : realDomainType} (T : Type).

Implicit Types (f g h : T -> R).

Lemma leff f : f <=1 f.
Proof. by []. Qed.

Lemma lef_trans g f h : f <=1 g -> g <=1 h -> f <=1 h.
Proof. by move=> h1 h2 x; apply/(le_trans (h1 x)). Qed.
End FFTheory.

(* -------------------------------------------------------------------- *)
Section Nbh.
Context {R : realType}.

Inductive nbh : \bar R -> predArgType :=
| NFin  (c e : R) of (0 < e) : nbh c%:E
| NPInf (M   : R) : nbh +oo
| NNInf (M   : R) : nbh -oo.

Coercion pred_of_nbh l (v : nbh l) :=
  match v with
  | @NFin  l e _ => [pred x : R | `|x - l| < e]
  | @NPInf M     => [pred x : R | x > M]
  | @NNInf M     => [pred x : R | x < M]
  end.
End Nbh.

(* -------------------------------------------------------------------- *)
Section NbhElim.
Context {R : realType}.

Lemma nbh_finW c (P : forall x, nbh x -> Prop) :
    (forall e (h : 0 < e), P _ (@NFin R c e h))
  -> forall (v : nbh c%:E), P _ v.
Proof.
move=> ih; move: {-2}c%:E (erefl c%:E).
by move=> e eE v; case: v eE => // c' e' h [->].
Qed.

Lemma nbh_pinfW (P : forall x, nbh x -> Prop) :
  (forall M, P _ (@NPInf R M)) -> forall (v : nbh +oo), P _ v.
Proof.
move=> ih; move: {-2}+oo%E (erefl (@EPInf R)).
by move=> e eE v; case: v eE => // c' e' h [->].
Qed.

Lemma nbh_ninfW (P : forall x, nbh x -> Prop) :
  (forall M, P _ (@NNInf R M)) -> forall (v : nbh -oo), P _ v.
Proof.
move=> ih ; move: {-2}-oo%E (erefl (@ENInf R)).
by move=> e eE v; case: v eE => // c' e' h [->].
Qed.
End NbhElim.

Arguments nbh_finW  : clear implicits.
Arguments nbh_pinfW : clear implicits.
Arguments nbh_ninfW : clear implicits.

(* -------------------------------------------------------------------- *)
Definition eclamp {R : realType} (e : R) :=
  if e <= 0 then 1 else e.

Lemma gt0_clamp {R : realType} (e : R) : 0 < eclamp e.
Proof. by rewrite /eclamp; case: (lerP e 0) => h //; apply/ltr01. Qed.

Lemma eclamp_id {R : realType} (e : R) : 0 < e -> eclamp e = e.
Proof. by rewrite ltNge /eclamp => /negbTE ->. Qed.

Definition B1 {R : realType} (x : R) :=
  @NFin R x 1 ltr01.

Definition B {R : realType} (x e : R) :=
  @NFin R x (eclamp e) (gt0_clamp e).

(* -------------------------------------------------------------------- *)
Lemma separable_le {R : realType} (l1 l2 : \bar R) :
  (l1 < l2)%E -> exists (v1 : nbh l1) (v2 : nbh l2),
    forall x y, x \in v1 -> y \in v2 -> x < y.
Proof.
case: l1 l2 => [l1||] [l2||] //= lt_l12; last first.
+ exists (NNInf 0), (NPInf 1) => x y; rewrite !inE => lt1 lt2.
  by apply/(lt_trans lt1)/(lt_trans ltr01).
+ exists (NNInf (l2-1)), (B1 l2) => x y; rewrite !inE.
  rewrite ltr_norml [-1 < _]ltr_subr_addl.
  by move => lt1 /andP[lt2 _]; apply/(lt_trans lt1).
+ exists (B1 l1), (NPInf (l1+1)) => x y; rewrite !inE.
  rewrite ltr_norml ltr_subl_addr [1+_]addrC => /andP[_].
  by move=> lt1 lt2; apply/(lt_trans lt1).
pose e := l2 - l1; exists (B l1 (e/2%:R)), (B l2 (e/2%:R)).
have gt0_e: 0 < e by rewrite subr_gt0.
move=> x y; rewrite !inE/= /eclamp pmulr_rle0 // invr_le0.
rewrite lern0 /= !ltr_distl => /andP[_ lt1] /andP[lt2 _].
apply/(lt_trans lt1)/(le_lt_trans _ lt2).
rewrite ler_subr_addl addrCA -mulrDl -mulr2n -mulr_natr.
by rewrite mulfK ?pnatr_eq0 //= /e addrCA subrr addr0.
Qed.

Lemma separable {R : realType} (l1 l2 : \bar R) :
  l1 != l2 -> exists (v1 : nbh l1) (v2 : nbh l2),
    forall x, x \notin [predI v1 & v2].
Proof.
wlog: l1 l2 / (l1 < l2)%E => [wlog ne_l12|le_l12 _].
  case/boolP: (l1 < l2)%E => [/wlog/(_ ne_l12)//|].
  rewrite -leNgt le_eqVlt eq_sym (negbTE ne_l12) /=.
  case/wlog=> [|x [y h]]; first by rewrite eq_sym.
  by exists y, x=> z; rewrite inE andbC /= (h z).
case/separable_le: le_l12 => [v1] [v2] h; exists v1, v2.
move=> x; apply/negP; rewrite inE/= => /andP[] xv1 xv2.
by have := h _ _ xv1 xv2; rewrite ltxx.
Qed.

(* -------------------------------------------------------------------- *)
Section SequenceLim.
Variable (R : realType).

Implicit Types (u v : nat -> R).

Definition ncvg u l :=
  forall v : nbh l, exists K, forall n, (K <= n)%N -> u n \in v.

Definition iscvg (u : nat -> R) := exists l, ncvg u l%:E.

Definition nbounded u :=
  exists v : nbh 0%:E, forall n, u n \in v.

Lemma nboundedP u :
  reflect (exists2 M, 0 < M & forall n, `|u n| < M) `[< nbounded u >].
Proof.
apply: (iffP idP) => [/asboolP[]|]; first elim/nbh_finW.
  move=> M /= gt0_M cv; exists M => [|n] //.
  by have := cv n; rewrite inE subr0.
case=> M _ cv; apply/asboolP; exists (B 0 M) => n; rewrite inE subr0.
by rewrite eclamp_id // (@le_lt_trans _ _ `|u 0%N|).
Qed.
End SequenceLim.

(* -------------------------------------------------------------------- *)
Notation "c %:S" := (fun _ : nat => c) (at level 2, format "c %:S").

Section SeqLimTh.
Variable (R : realType).

Implicit Types (u v : nat -> R) (c : R) (l : \bar R).

Lemma ncvg_uniq u l1 l2 : ncvg u l1 -> ncvg u l2 -> l1 = l2.
Proof.
move=> cv1 cv2; apply/eqP; case: (l1 =P l2) => // /eqP.
case/separable=> [n1] [n2] h; move: (cv1 n1) (cv2 n2).
case=> [K1 c1] [K2 c2]; pose K := maxn K1 K2.
move/(_ (u K)): h; rewrite !inE/= !(c1, c2) //.
  by apply/leq_maxl. by apply/leq_maxr.
Qed.

Lemma ncvg_eq_from K v u l :
  (forall n, (K <= n)%N -> u n = v n) -> ncvg v l -> ncvg u l.
Proof.
move=> eq cu nb; case: (cu nb) => Ku {}cu; exists (maxn K Ku) => n.
by rewrite geq_max => /andP[leK leKu]; rewrite eq // cu.
Qed.

Lemma ncvg_eq v u l : u =1 v -> ncvg v l -> ncvg u l.
Proof. by move=> eq; apply: (@ncvg_eq_from 0). Qed.

Lemma ncvg_le_from K v u (lv lu : \bar R) :
  (forall n, (K <= n)%N -> u n <= v n) -> ncvg v lv -> ncvg u lu -> (lu <= lv)%E.
Proof.
move=> le_uv cv cu; rewrite leNgt; apply/negP=> /separable_le.
case=> [v1] [v2] h; have [] := (cv v1, cu v2).
case=> [K1 vv1] [K2 uv2]; pose_big_enough K'.
have []// := And3 (le_uv K' _) (vv1 K' _) (uv2 K' _). 2: by close.
by move=> le h1 h2; have := h _ _ h1 h2; rewrite ltNge le.
Qed.

Lemma ncvg_le v u (lv lu : \bar R) :
  u <=1 v -> ncvg v lv -> ncvg u lu -> (lu <= lv)%E.
Proof. by move=> le_uv; apply/(@ncvg_le_from 0). Qed.

Lemma ncvg_nbounded u x : ncvg u x%:E -> nbounded u.
Proof.                   (* FIXME: factor out `sup` of a finite set *)
case/(_ (B x 1)) => K cu; pose S := [seq `|u n| | n <- iota 0 K].
pose M : R := sup [set x : R | x \in S]; pose e := Num.max (`|x| + 1) (M + 1).
apply/asboolP/nboundedP; exists e => [|n]; first by rewrite lt_maxr ltr_paddl.
case: (ltnP n K); last first.
  move/cu; rewrite inE eclamp_id ?ltr01 // => ltunBx1.
  rewrite lt_maxr; apply/orP; left; rewrite -[u n](addrK x) addrAC.
  by apply/(le_lt_trans (ler_norm_add _ _)); rewrite addrC ltr_add2l.
move=> lt_nK; have: `|u n| \in S; first by apply/map_f; rewrite mem_iota.
move=> un_S; rewrite lt_maxr; apply/orP; right.
case E: {+}K lt_nK => [|k] // lt_nSk; apply/ltr_spaddr; first apply/ltr01.
suff : has_sup (fun x : R => x \in S) by move/sup_upper_bound/ubP => ->.
split; first by exists `|u 0%N|; rewrite /S E inE eqxx.
elim: {+}S => [|v s [ux /ubP hux]]; first by exists 0; apply/ubP.
exists (Num.max v ux); apply/ubP=> y; rewrite inE => /orP[/eqP->|].
  by rewrite le_maxr lexx.
by move/hux=> le_yux; rewrite le_maxr le_yux orbT.
Qed.

Lemma nboundedC c : nbounded c%:S.
Proof.
apply/asboolP/nboundedP; exists (`|c| + 1).
  by rewrite ltr_spaddr. by move=> _; rewrite ltr_addl.
Qed.

Lemma ncvgC c : ncvg c%:S c%:E.
Proof.
elim/nbh_finW => e /= gt0_e; exists 0%N => n _.
by rewrite inE subrr normr0.
Qed.

Lemma ncvgD u v lu lv : ncvg u lu%:E -> ncvg v lv%:E ->
  ncvg (u \+ v) (lu + lv)%:E.
Proof.
move=> cu cv; elim/nbh_finW => e /= gt0_e; pose z := e / 2%:R.
case: (cu (B lu z)) (cv (B lv z)) => [ku {}cu] [kv {}cv].
exists (maxn ku kv) => n; rewrite geq_max => /andP[leu lev].
rewrite inE opprD addrACA (le_lt_trans (ler_norm_add _ _)) //.
move: (cu _ leu) (cv _ lev); rewrite !inE eclamp_id.
  by rewrite mulr_gt0 // invr_gt0 ltr0Sn.
move=> cu' cv'; suff ->: e = z + z by rewrite ltr_add.
by rewrite -mulrDl -mulr2n -mulr_natr mulfK ?pnatr_eq0.
Qed.

Lemma ncvgN u lu : ncvg u lu -> ncvg (- u) (- lu).
Proof.
case: lu => [lu||] cu /=; first last.
+ elim/nbh_pinfW=> M; case: (cu (NNInf (-M))) => K {}cu.
  by exists K => n /cu; rewrite !inE ltr_oppr.
+ elim/nbh_ninfW=> M; case: (cu (NPInf (-M))) => K {}cu.
  by exists K => n /cu; rewrite !inE ltr_oppl.
elim/nbh_finW => e /= gt0_e; case: (cu (B lu e)).
by move=> K {}cu; exists K=> n /cu; rewrite !inE -opprD normrN eclamp_id.
Qed.

Lemma ncvgN_fin u lu : ncvg u lu%:E -> ncvg (- u) (- lu)%:E.
Proof. by apply/ncvgN. Qed.

Lemma ncvgB u v lu lv : ncvg u lu%:E -> ncvg v lv%:E ->
  ncvg (u \- v) (lu - lv)%:E.
Proof. by move=> cu cv; apply/ncvgD/ncvgN_fin. Qed.

Lemma ncvg_abs u lu : ncvg u lu%:E -> ncvg (fun n => `|u n|) `|lu|%:E.
Proof.
move=> cu; elim/nbh_finW => e /= gt0_e; case: (cu (B lu e)).
move=> K {}cu; exists K=> n /cu; rewrite !inE eclamp_id //.
by move/(le_lt_trans (ler_dist_dist _ _)).
Qed.

Lemma ncvg_abs0 u : ncvg (fun n => `|u n|) 0%:E -> ncvg u 0%:E.
Proof.
move=> cu; elim/nbh_finW => e /= gt0_e; case: (cu (B 0 e)).
by move=> K {}cu; exists K=> n /cu; rewrite !inE !subr0 eclamp_id // normr_id.
Qed.

Lemma ncvgMl u v : ncvg u 0%:E -> nbounded v -> ncvg (u \* v) 0%:E.
move=> cu /asboolP/nboundedP [M gt0_M ltM]; elim/nbh_finW => e /= gt0_e.
case: (cu (B 0 (e / (M + 1)))) => K {}cu; exists K => n le_Kn.
rewrite inE subr0 normrM; apply/(@lt_trans _ _ (e / (M + 1) * M)).
  apply/ltr_pmul => //; have /cu := le_Kn; rewrite inE subr0 eclamp_id //.
  by rewrite mulr_gt0 // invr_gt0 addr_gt0.
rewrite -mulrAC -mulrA gtr_pmulr // ltr_pdivr_mulr ?addr_gt0 //.
by rewrite mul1r ltr_addl.
Qed.

Lemma ncvgMr u v : ncvg v 0%:E -> nbounded u -> ncvg (u \* v) 0%:E.
Proof.
move=> cv bu; apply/(@ncvg_eq (v \* u)).
  by move=> x; rewrite /= mulrC.
by apply/ncvgMl.
Qed.

Lemma ncvgM u v lu lv : ncvg u lu%:E -> ncvg v lv%:E ->
  ncvg (u \* v) (lu * lv)%:E.
Proof.
move=> cu cv; pose a := u \- lu%:S; pose b := v \- lv%:S.
have eq: (u \* v) =1 (lu * lv)%:S \+ ((lu%:S \* b) \+ (a \* v)).
  move=> n; rewrite {}/a {}/b /= [u n+_]addrC [(_+_)*(v n)]mulrDl.
  rewrite !addrA -[LHS]add0r; congr (_ + _); rewrite mulrDr.
  by rewrite !(mulrN, mulNr) (addrCA (lu * lv)) subrr addr0 subrr.
apply/(ncvg_eq eq); rewrite -[X in X%:E]addr0; apply/ncvgD.
  by apply/ncvgC. rewrite -[X in X%:E]addr0; apply/ncvgD.
+ apply/ncvgMr; first rewrite -[X in X%:E](subrr lv).
    by apply/ncvgB/ncvgC. by apply/nboundedC.
+ apply/ncvgMl; first rewrite -[X in X%:E](subrr lu).
    by apply/ncvgB/ncvgC. by apply/(ncvg_nbounded cv).
Qed.

Lemma ncvgZ c u lu : ncvg u lu%:E -> ncvg (c \*o u) (c * lu)%:E.
Proof. by move=> cu; apply/ncvgM => //; apply/ncvgC. Qed.

Lemma ncvg_leC c u (lu : \bar R) :
  (forall n, u n <= c) -> ncvg u lu -> (lu <= c%:E)%E.
Proof. by move=> le cu; apply/(@ncvg_le c%:S u)=> //; apply/ncvgC. Qed.

Lemma ncvg_geC c u (lu : \bar R) :
  (forall n, c <= u n) -> ncvg u lu -> (c%:E <= lu)%E.
Proof. by move=> le cu; apply/(@ncvg_le u c%:S)=> //; apply/ncvgC. Qed.

Lemma iscvgC c : iscvg c%:S.
Proof. by exists c; apply/ncvgC. Qed.

Hint Resolve iscvgC : core.

Lemma iscvgD (u v : nat -> R) : iscvg u -> iscvg v -> iscvg (u \+ v).
Proof. by case=> [lu cu] [lv cv]; exists (lu + lv); apply/ncvgD. Qed.

Lemma iscvg_sum {I : eqType} (u : I -> nat -> R) r :
  (forall i, i \in r -> iscvg (u i)) ->
    iscvg (fun n => \sum_(i <- r) u i n).
Proof.
elim: r => [|i r ih] h.
  by exists 0; apply/(@ncvg_eq 0%:S)/ncvgC => n; rewrite big_nil.
case: ih => [j jr|c cv]; first by apply/h; rewrite inE jr orbT.
have [l cl]: iscvg (u i) by apply/h; rewrite inE eqxx.
exists (c + l); have := ncvgD cv cl; apply/ncvg_eq.
by move=> n; rewrite big_cons addrC.
Qed.

Lemma iscvg_eq (u v : nat -> R) :
  u =1 v -> iscvg v -> iscvg u.
Proof. by move=> equv [l h]; exists l; apply/(ncvg_eq equv). Qed.

Lemma ncvg_sub h u lu :
     {homo h : x y / (x < y)%N}
  -> ncvg u lu -> ncvg (fun n => u (h n)) lu.
Proof.
move=> mono_h cvu v; case: (cvu v)=> K {}cvu; exists K.
move=> n le_Kn; apply/cvu; apply/(leq_trans le_Kn).
elim: {le_Kn} n => [|n ih] //; apply/(leq_ltn_trans ih).
by rewrite mono_h.
Qed.

Lemma iscvg_sub σ u :
  {homo σ : x y / (x < y)%N} -> iscvg u -> iscvg (u \o σ).
Proof. by move=> homoσ [l h]; exists l; apply/ncvg_sub. Qed.

Lemma ncvg_shift k (u : nat -> R) l :
  ncvg u l <-> ncvg (fun n => u (n + k)%N) l.
Proof. split => h v; move/(_ v): h => [K h].
+ by exists K => n leKn; apply/h/(leq_trans leKn)/leq_addr.
+ exists (K + k)%N => n leKkn; rewrite -[n](@subnK k).
  * by apply/(leq_trans _ leKkn)/leq_addl.
  apply/h/(@leq_trans ((K+k) - k))/leq_sub2r => //.
  by rewrite addnK.
Qed.

Lemma iscvg_shift k (u : nat -> R) :
  iscvg u <-> iscvg (fun n => u (n + k)%N).
Proof. by split=> -[l h]; exists l; apply/(ncvg_shift _ u). Qed.

Lemma ncvg_gt (u : nat -> R) (l1 l2 : \bar R) :
  (l1 < l2)%E -> ncvg u l2 ->
    exists K, forall n, (K <= n)%N -> (l1 < (u n)%:E)%E.
Proof.
case: l1 l2 => [l1||] [l2||] //=; first last.
+ by move=> _ _; exists 0%N => ? ?; exact: ltNyr.
+ by move=> _ _; exists 0%N => ? ?; exact: ltNyr.
+ by move=> _ /(_ (NPInf l1)) [K cv]; exists K => n /cv.
move=> lt_12; pose e := l2 - l1 => /(_ (B l2 e)).
case=> K cv; exists K => n /cv; rewrite !inE eclamp_id ?subr_gt0 //.
rewrite ltr_distl => /andP[] /(le_lt_trans _) h _; apply: h.
by rewrite {cv}/e opprB addrCA subrr addr0.
Qed.

Lemma ncvg_lt (u : nat -> R) (l1 l2 : \bar R) :
  (l1 < l2)%E -> ncvg u l1 ->
    exists K, forall n, (K <= n)%N -> ((u n)%:E < l2)%E.
Proof.
move=> lt_12 cv_u_l1; case: (@ncvg_gt (- u) (-l2) (-l1)).
  by rewrite lte_opp2. by apply/ncvgN.
by move=> K cv; exists K => n /cv; rewrite (@lte_opp2 _ _ (u n)%:E).
Qed.

Lemma ncvg_homo_lt (u : nat -> R) (l1 l2 : \bar R) :
    (forall m n, (m <= n)%N -> u m <= u n)
  -> (l1 < l2)%E -> ncvg u l1 -> forall n, ((u n)%:E < l2)%E.
Proof.
move=> homo_u lt_12 cvu n; have [K {cvu}cv] := ncvg_lt lt_12 cvu.
case: (leqP n K) => [/homo_u|/ltnW /cv //].
by move/lee_tofin/le_lt_trans; apply; apply/cv.
Qed.

Lemma ncvg_homo_le (u : nat -> R) (l : \bar R) :
    (forall m n, (m <= n)%N -> u m <= u n)
  -> ncvg u l -> forall n, ((u n)%:E <= l)%E.
Proof.
move=> homo_u cvu n; rewrite leNgt.
by apply/negP => /ncvg_homo_lt /(_ cvu) -/(_ homo_u n); rewrite ltxx.
Qed.
End SeqLimTh.

(* -------------------------------------------------------------------- *)
Section LimOp.
Context {R : realType}.

Implicit Types (u v : nat -> R).

Definition nlim u : \bar R :=
  if @idP `[< exists l, `[< ncvg u l >] >] is ReflectT Px then
    xchoose (asboolP _ Px) else -oo.

Lemma nlim_ncvg u : (exists l, ncvg u l) -> ncvg u (nlim u).
Proof.
case=> l cv_u_l; rewrite /nlim; case: {-}_ / idP; last first.
  by case; apply/asboolP; exists l; apply/asboolP.
by move=> p; apply/asboolP/(xchooseP (asboolP _ p)).
Qed.

Lemma nlim_out u : ~ (exists l, ncvg u l) -> nlim u = -oo%E.
Proof.
move=> h; rewrite /nlim; case: {-}_ / idP => // p.
by case: h; case/asboolP: p => l /asboolP; exists l.
Qed.

CoInductive nlim_spec (u : nat -> R) : \bar R -> Type :=
| NLimCvg l : ncvg u l -> nlim_spec u l
| NLimOut   : ~ (exists l, ncvg u l) -> nlim_spec u -oo.

Lemma nlimP u : nlim_spec u (nlim u).
Proof.
case/boolP: `[< exists l, `[< ncvg u l >] >] => /asboolP/exists_asboolP/asboolP.
  by move/nlim_ncvg=> h; apply/NLimCvg.
by move=> h; rewrite nlim_out //; apply/NLimOut.
Qed.

Lemma nlimE (u : nat -> R) (l : \bar R) : ncvg u l -> nlim u = l.
Proof.
move=> cu; have: (ncvg u (nlim u)).
  by apply/nlim_ncvg; exists l. by move/(ncvg_uniq cu) => ->.
Qed.

Lemma nlimC c : nlim c%:S = c%:E :> \bar R.
Proof. by move/nlimE: (@ncvgC R c). Qed.

Lemma nlimD (u v : nat -> R) : iscvg u -> iscvg v ->
  nlim (u \+ v) = (nlim u + nlim v)%E.
Proof.
case=> [lu cu] [lv cv]; rewrite (nlimE cu) (nlimE cv) /=.
by rewrite (nlimE (ncvgD cu cv)).
Qed.

Lemma eq_from_nlim K (v u : nat -> R) :
  (forall n, (K <= n)%N -> u n = v n) -> nlim u = nlim v.
Proof.
move=> eq; have h := ncvg_eq_from eq; case: (nlimP v).
  by move=> l cv; have cu := h _ cv; rewrite (nlimE cu).
move=> Ncv; rewrite nlim_out //; case=> l cu.
apply: Ncv; exists l; apply/(@ncvg_eq_from _ K u) => //.
by move=> n /eq /esym.
Qed.

Lemma eq_nlim (v u : nat -> R) : u =1 v -> nlim u = nlim v.
Proof. by move=> eq; apply/(@eq_from_nlim 0) => n _; apply/eq. Qed.

Lemma nlim_bump (u : nat -> R) : nlim (fun n => u n.+1) = nlim u.
Proof.
case: (nlimP u) => [l cu|Ncu].
  suff: ncvg (fun n => u n.+1) l by move/nlimE.
  move=> v; case/(_ v): cu => K cu; exists K => n le_Kn.
  by apply/cu; apply/(leq_trans le_Kn).
rewrite nlim_out //; case=> l cu; apply/Ncu; exists l.
move=> v; case/(_ v): cu => K cu; exists K.+1 => n le_Kn.
rewrite -[n]prednK; first by apply/(leq_trans _ le_Kn).
by apply/cu; rewrite -ltnS prednK ?(leq_trans _ le_Kn).
Qed.

Lemma nlim_lift (u : nat -> R) p : nlim (fun n => u (n + p)%N) = nlim u.
Proof.
elim: p => [|p ih]; first by apply/eq_nlim=> k; rewrite addn0.
rewrite -ih -[in RHS]nlim_bump; apply/eq_nlim=> k /=.
by rewrite addSnnS.
Qed.

Lemma nlim_sum {I : eqType} (u : I -> nat -> R) (r : seq I) :
  (forall i, i \in r -> iscvg (u i)) ->
      nlim (fun n => \sum_(i <- r) (u i) n)
    = (\sum_(i <- r) nlim (u i))%E.
Proof.
elim: r => /= [|i r ih] h; first rewrite big_nil.
  by rewrite (@eq_nlim 0%:S) ?nlimC //= => n; rewrite big_nil.
rewrite big_cons -ih -?nlimD.
  by move=> j jr; apply/h; rewrite inE jr orbT.
  by apply/h; rewrite inE eqxx.
  by apply/iscvg_sum=> j jr; apply/h; rewrite inE jr orbT.
by apply/eq_nlim=> n /=; rewrite big_cons.
Qed.

Lemma nlim_sumR {I : eqType} (u : I -> nat -> R) (r : seq I) :
    (forall i, i \in r -> iscvg (u i)) ->
  nlim (fun n => \sum_(i <- r) (u i) n) = (\sum_(i <- r)
    (fine (nlim (u i)) : R))%:E.
Proof.
move=> h; rewrite nlim_sum //; elim: r h => [|i r ih] h.
  by rewrite !big_nil.
rewrite !big_cons; case: (h i); first by rewrite inE eqxx.
move=> c /nlimE ->; rewrite ih // => j jr.
by apply/h; rewrite inE jr orbT.
Qed.

Lemma nlim_sup (u : nat -> R) l :
    (forall n m, (n <= m)%N -> u n <= u m)
  -> ncvg u l%:E
  -> sup [set r | exists n, r = u n] = l.
Proof.
move=> mn_u cv_ul; set S := (X in sup X); suff: ncvg u (sup S)%:E.
  by move/nlimE; move/nlimE: cv_ul => -> [->].
elim/nbh_finW=> /= e gt0_e; have sS: has_sup S.
  split; first exists (u 0%N).
    by exists 0%N.
  exists l; apply/ubP => _ [n ->].
  by rewrite -lee_fin; apply/ncvg_homo_le.
have /sup_adherent := sS => /(_ _ gt0_e) [r] [N ->] lt_uN.
exists N => n le_Nn; rewrite !inE distrC ger0_norm ?subr_ge0.
  by move/ubP : (sup_upper_bound sS) => -> //; exists n.
by rewrite ltr_subl_addr -ltr_subl_addl (lt_le_trans lt_uN) ?mn_u.
Qed.

End LimOp.

(* -------------------------------------------------------------------- *)


(**************************************************************************)
(*  Copyright 2010 2011, Thomas Braibant                                  *)
(*                                                                        *)
(**************************************************************************)

Require Import Common Axioms Base Finite.

(** This file defines a functionnal implementation of the Semantics of
circuits, for loopless ones. We define a simplified model of circuits,
called Loopless, which is identical to traditionnal circuits, except
in the fact that there is no Loop combinator. Compilation is done by a
function of type [circuit -> Maybe.T loopless] *)

Module Maybe.
  Definition T (a : Type) := option a.
  Definition return_ {A : Type} (x : A) : T A := Some x.
  Definition fail {A : Type } : T A := None.
  Definition bind {A B : Type} (a : T A) (f : A -> T B) : T B :=
    match a with
      | Some x => f x
      | None => None
    end.

  Lemma bind_Some {A B} (a : T A) (y : B) (f : A -> T B) :
    bind a f = Some y ->
    exists x,( a = Some x /\ f x = Some y ).
  Proof.
    intros.
    destruct a.  exists a. intuition.
    simpl in H. discriminate.
  Qed.
End Maybe.

Notation "x >> f" := (Maybe.bind x f) (at level 60).
Notation "'do' a <- e ; c" := (e >> (fun a => c)) (at level 60, right associativity).

Module Type T.
  Variable tech : Techno.
  Variable data : Type.

  Variable sem : forall a b, tech a b -> (a -> data) -> option (b -> data).
End T.

Module SIM (X : T).
  Import X.
  Existing Instance tech.
  Require Import Program.

  Program Fixpoint sim n m (c : circuit n m) : (n -> data) -> option (m -> data) :=
    match c with
      | Atom n m Hfn Hfm x => fun e => sem n m x  e
      | Ser n m p x y => fun e =>
        do e <- sim n m x e;
        sim m p y e
      | Par n m p q x y =>  fun e =>
        do e1 <- sim n p x (fun u => e (inl u) );
        do e2 <- sim m q y (fun u => e (inr u) );
          Maybe.return_ (Data.app e1 e2)
      | Plug n m Hfn Hfm f =>
        fun e => Maybe.return_ (fun X => e (f X))
      | Loop n m l x => fun _ => Maybe.fail
    end.
End SIM.


Require Export Db.Spec.
Require Export Db.Lemmas.

Require Export RecTypes.SpecTypes.
Require Export RecTypes.InstTy.
Require Export RecTypes.Contraction.
Require Export RecTypes.ValidTy.
Require Export RecTypes.LemmasTypes.

Require Export StlcIso.Inst.
Require Export StlcIso.SpecTyping.

Require Import Coq.Bool.Bool.
Require Import Coq.micromega.Lia.

Ltac crushTypingMatchH :=
  match goal with
    | [ H: ⟪ _ : _ r∈ empty ⟫         |- _ ] =>
      inversion H
    | [ H: ⟪ 0 : _ r∈ _ ⟫         |- _ ] =>
      apply getEvarInvHere in H; repeat subst
    | [ H: ⟪ (S _) : _ r∈ (_ r▻ _) ⟫ |- _ ] =>
      apply getEvarInvThere in H
    | [ |- ⟪ 0 : _ r∈ _ ⟫ ] => apply GetEvarHere
    | [ |- ⟪ S _ : _ r∈ _ ⟫ ] => apply GetEvarThere
    (* | H: ⟪ _ i⊢ var _        : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ abs _ _      : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ app _ _      : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ unit         : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ true         : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ false        : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ ite _ _ _    : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ pair _ _     : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ proj₁ _      : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ proj₂ _      : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ inl _        : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ inr _        : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ caseof _ _ _ : _ ⟫ |- _ => inversion H; clear H *)

    (* | H: ⟪ _ i⊢ fold_ _ : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ unfold_ _ : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ i⊢ seq _ _      : _ ⟫ |- _ => inversion H; clear H *)
    | [ wi : ⟪ ?i : _ r∈ (_ r▻ _) ⟫
        |- context [match ?i with _ => _ end]
      ] => destruct i
    | [ wi : ⟪ ?i : _ r∈ (_ r▻ _) ⟫
        |- context [(_ · _) ?i]
      ] => destruct i
    | [ |- ⟪ _ i⊢ var _ : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ i⊢ abs _ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ _ i⊢ app _ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ _ i⊢ unit : _ ⟫                     ] => econstructor
    | [ |- ⟪ _ i⊢ true : _ ⟫                     ] => econstructor
    | [ |- ⟪ _ i⊢ false : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ i⊢ ite _ _ _ : _ ⟫                ] => econstructor
    | [ |- ⟪ _ i⊢ pair _ _ : _ ⟫                 ] => econstructor
    | [ |- ⟪ _ i⊢ proj₁ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ _ i⊢ proj₂ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ _ i⊢ inl _ : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ i⊢ inr _ : _ ⟫                    ] => econstructor
    | [ |- ⟪ _ i⊢ caseof _ _ _ : _ ⟫             ] => econstructor

    | [ |- ⟪ _ i⊢ fold_ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ _ i⊢ unfold_ _ : _ ⟫                ] => econstructor
    | [ |- ⟪ _ i⊢ seq _ _ : _ ⟫                  ] => econstructor
    | [ |- ⟪ i⊢ phole : _ , _ → _ , _ ⟫          ] => econstructor
    | [ |- ⟪ i⊢ pabs _ _ : _ , _ → _ , _ ⟫       ] => econstructor
    | [ |- ⟪ i⊢ papp₁ _ _ : _ , _ → _ , _ ⟫      ] => econstructor
    | [ |- ⟪ i⊢ papp₂ _ _ : _ , _ → _ , _ ⟫      ] => econstructor
    | [ |- ⟪ i⊢ pite₁ _ _ _ : _ , _ → _ , _ ⟫    ] => econstructor
    | [ |- ⟪ i⊢ pite₂ _ _ _ : _ , _ → _ , _ ⟫    ] => econstructor
    | [ |- ⟪ i⊢ pite₃ _ _ _ : _ , _ → _ , _ ⟫    ] => econstructor
    | [ |- ⟪ i⊢ ppair₁ _ _ : _ , _ → _ , _ ⟫     ] => econstructor
    | [ |- ⟪ i⊢ ppair₂ _ _ : _ , _ → _ , _ ⟫     ] => econstructor
    | [ |- ⟪ i⊢ pproj₁ _ : _ , _ → _ , _ ⟫       ] => econstructor
    | [ |- ⟪ i⊢ pproj₂ _ : _ , _ → _ , _ ⟫       ] => econstructor
    | [ |- ⟪ i⊢ pinl _ : _ , _ → _ , _ ⟫         ] => econstructor
    | [ |- ⟪ i⊢ pinr _ : _ , _ → _ , _ ⟫         ] => econstructor
    | [ |- ⟪ i⊢ pcaseof₁ _ _ _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ i⊢ pcaseof₂ _ _ _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ i⊢ pcaseof₃ _ _ _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ i⊢ pseq₁ _ _ : _ , _ → _ , _ ⟫      ] => econstructor
    | [ |- ⟪ i⊢ pseq₂ _ _ : _ , _ → _ , _ ⟫      ] => econstructor
    | [ |- ⟪ i⊢ pfold _ : _ , _ → _ , _ ⟫ ] => econstructor
    | [ |- ⟪ i⊢ punfold _ : _ , _ → _ , _ ⟫ ] => econstructor
  end.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushTypingMatchH);
  try discriminate;
  eauto with ws.

Lemma getEvar_wsIx Γ i T :
  ⟪ i : T r∈ Γ ⟫ → dom Γ ∋ i.
Proof. induction 1; crush. Qed.
#[export]
Hint Resolve getEvar_wsIx : ws.

(* Lemma wsIx_getEvar {Γ i} (wi: dom Γ ∋ i) : *)
(*   ∀ (P: Prop), (∀ T, ⟪ i : T ∈ Γ ⟫ → P) → P. *)
(* Proof. *)
(*   depind wi; destruct Γ; crush. *)
(*   - eapply (IHwi _ x); crush. *)
(* Qed. *)

(* Lemma wtRen_wsRen Γ₁ Γ₂ ξ : *)
(*   WtRen Γ₁ Γ₂ ξ → WsRen (dom Γ₁) (dom Γ₂) ξ. *)
(* Proof. *)
(*   unfold WtRen, WsRen; intros. *)
(*   apply (wsIx_getEvar H0); crush. *)
(* Qed. *)

(* Lemma typing_wt {Γ t T} (wt: ⟪ Γ ⊢ t : T ⟫) : *)
(*   wsTm (dom Γ) t. *)
(* Proof. induction wt; crush. Qed. *)

(* Lemma wtSub_wsSub Γ₁ Γ₂ ζ : *)
(*   WtSub Γ₁ Γ₂ ζ → WsSub (dom Γ₁) (dom Γ₂) ζ. *)
(* Proof. *)
(*   unfold WtSub, WsSub; intros. *)
(*   apply (wsIx_getEvar H0); crush. *)
(*   eauto using typing_wt. *)
(* Qed. *)

(*************************************************************************)

Lemma wtRen_closed ξ Δ : WtRen empty Δ ξ.
Proof. unfold WtRen; intros. inversion H. Qed.
#[export]
Hint Resolve wtRen_closed : ws.

Lemma wtRen_idm (Γ: Env) : WtRen Γ Γ (idm Ix).
Proof. unfold WtRen, idm; auto. Qed.
#[export]
Hint Resolve wtRen_idm : ws.

Lemma wtRen_comp {Γ₁ Γ₂ Γ₃ ξ₁ ξ₂} :
  WtRen Γ₁ Γ₂ ξ₁ → WtRen Γ₂ Γ₃ ξ₂ → WtRen Γ₁ Γ₃ (ξ₁ >-> ξ₂).
Proof. unfold WtRen, comp; simpl; auto. Qed.
#[export]
Hint Resolve wtRen_comp : ws.

(*************************************************************************)

Definition WtRenNatural (Γ₁ Γ₂: Env) (ξ₁ ξ₂: Sub Ix) : Prop :=
  ∀ i T, ⟪ (ξ₁ i) : T r∈ Γ₁ ⟫ → ⟪ (ξ₂ i) : T r∈ Γ₂ ⟫.

Lemma wtRen_natural
  {f₁ f₂: Env → Env} {ξ₁ ξ₂: Sub Ix}
  (hyp: ∀ Γ, WtRenNatural (f₁ Γ) (f₂ Γ) ξ₁ ξ₂) :
  ∀ Γ₁ Γ₂ ξ,
    WtRen Γ₁ (f₁ Γ₂) (ξ >-> ξ₁) →
    WtRen Γ₁ (f₂ Γ₂) (ξ >-> ξ₂).
Proof. unfold WtRenNatural, WtRen in *; eauto. Qed.

(*************************************************************************)

Lemma wtRen_wkms (Δ: Env) :
  ∀ Γ, WtRen Γ (Γ r▻▻ Δ) (wkms (dom Δ)).
Proof. unfold WtRen. induction Δ; crush. Qed.
#[export]
Hint Resolve wtRen_wkms : ws.

Lemma wtiIx_wkms (Δ: Env) :
  ∀ (Γ: Env) (i: Ix) T,
    ⟪ (wkms (dom Δ) i) : T r∈ (Γ r▻▻ Δ) ⟫ → ⟪ i : T r∈ Γ ⟫.
Proof. induction Δ; eauto with wsi. Qed.
#[export]
Hint Resolve wtiIx_wkms : wsi.

Lemma wtRen_wkm Γ T :
  WtRen Γ (Γ r▻ T) wkm.
Proof. apply (wtRen_wkms (empty r▻ T)). Qed.
#[export]
Hint Resolve wtRen_wkm : ws.

Lemma wtiIx_wkm Γ i T :
  ⟪ (wkm i) : T r∈ (Γ r▻ T) ⟫ → ⟪ i : T r∈ Γ ⟫.
Proof. apply (wtiIx_wkms (empty r▻ T)). Qed.
#[export]
Hint Resolve wtiIx_wkm : wsi.

Lemma wtRenNatural_wkms_id Δ :
  ∀ Γ, WtRenNatural (Γ r▻▻ Δ) Γ (wkms (dom Δ)) (idm Ix).
Proof. unfold WtRenNatural; eauto using wtiIx_wkms. Qed.
#[export]
Hint Resolve wtRenNatural_wkms_id : wsi.

Lemma wtiRen_comp_wkms Δ :
  ∀ Γ₁ Γ₂ ξ,
    WtRen Γ₁ (Γ₂ r▻▻ Δ) (ξ >-> wkms (dom Δ)) →
    WtRen Γ₁ Γ₂        ξ.
Proof. apply (wtRen_natural (wtRenNatural_wkms_id Δ)). Qed.
#[export]
Hint Resolve wtiRen_comp_wkms : wsi.

Lemma wtRen_snoc Γ₁ Γ₂ ξ x T :
  WtRen Γ₁ Γ₂ ξ → ⟪ x : T r∈ Γ₂ ⟫ → WtRen (Γ₁ r▻ T) Γ₂ (ξ · x).
Proof. unfold WtRen. crush. Qed.
#[export]
Hint Resolve wtRen_snoc : ws.

Lemma wtiRen_snoc Γ₁ Γ₂ T ξ x :
  WtRen (Γ₁ r▻ T) Γ₂ (ξ · x) → WtRen Γ₁ Γ₂ ξ.
Proof.
  intros wξ i. specialize (wξ (S i)). eauto using GetEvar.
Qed.
#[export]
Hint Resolve wtiRen_snoc : wsi.

Lemma wtiIx_snoc Γ₁ Γ₂ ξ T x :
  WtRen (Γ₁ r▻ T) Γ₂ (ξ · x) → ⟪ x : T r∈ Γ₂ ⟫.
Proof.
  intros wξ. specialize (wξ 0). eauto using GetEvar.
Qed.
#[export]
Hint Resolve wtiIx_snoc : wsi.

Lemma wtRen_up {Γ₁ Γ₂ ξ} (wξ: WtRen Γ₁ Γ₂ ξ) :
  ∀ T, WtRen (Γ₁ r▻ T) (Γ₂ r▻ T) (ξ ↑).
Proof. unfold up; crush. Qed.
#[export]
Hint Resolve wtRen_up : ws.

Lemma wtiRen_up Γ₁ Γ₂ ξ T :
  WtRen (Γ₁ r▻ T) (Γ₂ r▻ T) (ξ ↑) → WtRen Γ₁ Γ₂ ξ.
Proof.
  unfold up, WtRen. crush.
  specialize (H (S i) T0). eauto with ws wsi.
Qed.
#[export]
Hint Resolve wtiRen_up : wsi.

Lemma wtRen_ups Γ₁ Γ₂ Δ ξ :
  WtRen Γ₁ Γ₂ ξ → WtRen (Γ₁ r▻▻ Δ) (Γ₂ r▻▻ Δ) (ξ ↑⋆ dom Δ).
Proof. induction Δ; crush. Qed.
#[export]
Hint Resolve wtRen_ups : ws.

Lemma wtiRen_ups Γ₁ Γ₂ Δ ξ :
  WtRen (Γ₁ r▻▻ Δ) (Γ₂ r▻▻ Δ) (ξ ↑⋆ dom Δ) → WtRen Γ₁ Γ₂ ξ.
Proof. induction Δ; eauto with wsi. Qed.
#[export]
Hint Resolve wtiRen_ups : wsi.

Lemma wtRen_beta (Γ Δ: Env) :
  ∀ ξ, WtRen Δ Γ ξ → WtRen (Γ r▻▻ Δ) Γ (beta (dom Δ) ξ).
Proof. unfold WtRen; induction Δ; crush. Qed.
#[export]
Hint Resolve wtRen_beta : ws.

Lemma typing_ren {Γ₁ t T} (wt: ⟪ Γ₁ i⊢ t : T ⟫) :
  ∀ Γ₂ ξ, WtRen Γ₁ Γ₂ ξ → ⟪ Γ₂ i⊢ t[ξ] : T ⟫.
Proof. induction wt; econstructor; crush. Qed.
#[export]
Hint Resolve typing_ren : ws.

(* Lemma typing_weakening Δ {Γ t T} (wt: ⟪ Γ ⊢ t : T ⟫) : *)
(*   ⟪ Γ ▻▻ Δ ⊢ t[@wkms Ix _ _ (dom Δ)] : T ⟫. *)
(* Proof. apply (typing_ren wt), wtRen_wkms. Qed. *)

(* Lemma typing_weakening1 T' {Γ t T} (wt: ⟪ Γ ⊢ t : T ⟫) : *)
(*   ⟪ Γ ▻ T' ⊢ t[@wkm Ix _ _] : T ⟫. *)
(* Proof. apply (typing_weakening (empty ▻ T') wt). Qed. *)

(*************************************************************************)

Lemma wtSub_closed ζ Δ : WtSub empty Δ ζ.
Proof. inversion 1. Qed.
#[export]
Hint Resolve wtSub_closed : ws.

Lemma wtSub_idm (Γ: Env) : WtSub Γ Γ (idm Tm).
Proof. unfold WtSub. crush. Qed.
#[export]
Hint Resolve wtSub_idm : ws.

Lemma wtSub_snoc Γ₁ Γ₂ ζ t T :
  WtSub Γ₁ Γ₂ ζ → ⟪ Γ₂ i⊢ t : T ⟫ → WtSub (Γ₁ r▻ T) Γ₂ (ζ · t).
Proof. unfold WtSub. crush. Qed.
#[export]
Hint Resolve wtSub_snoc : ws.

Lemma wtiSub_snoc Γ₁ Γ₂ T ζ t :
  WtSub (Γ₁ r▻ T) Γ₂ (ζ · t) → WtSub Γ₁ Γ₂ ζ.
Proof.
  intros wζ i. specialize (wζ (S i)). eauto using GetEvar.
Qed.
#[export]
Hint Resolve wtiSub_snoc : wsi.

Lemma wtSub_toSub ξ Γ₁ Γ₂ :
  WtRen Γ₁ Γ₂ ξ → WtSub Γ₁ Γ₂ ⌈ξ⌉.
Proof. unfold WtRen, WtSub; eauto using WtVar. Qed.

Lemma wtSub_wkms (Δ: Env) :
  ∀ Γ, WtSub Γ (Γ r▻▻ Δ) ⌈@wkms Ix _ _ (dom Δ)⌉.
Proof. eauto using wtRen_wkms, wtSub_toSub. Qed.
#[export]
Hint Resolve wtSub_wkms : ws.

Lemma wtSub_wkm Γ T :
  WtSub Γ (Γ r▻ T) ⌈wkm⌉.
Proof. apply (wtSub_wkms (empty r▻ T)). Qed.
#[export]
Hint Resolve wtSub_wkm : ws.

Lemma wtSub_up {Γ₁ Γ₂ ζ} (wζ: WtSub Γ₁ Γ₂ ζ) :
  ∀ T, WtSub (Γ₁ r▻ T) (Γ₂ r▻ T) (ζ ↑).
Proof. inversion 1; crush. Qed.
#[export]
Hint Resolve wtSub_up : ws.

Lemma wtSub_ups Γ₁ Γ₂ Δ ζ :
  WtSub Γ₁ Γ₂ ζ → WtSub (Γ₁ r▻▻ Δ) (Γ₂ r▻▻ Δ) (ζ ↑⋆ dom Δ).
Proof. induction Δ; crush. Qed.
#[export]
Hint Resolve wtSub_ups : ws.

Lemma typing_sub {Γ₁ t T} (wt: ⟪ Γ₁ i⊢ t : T ⟫) :
  ∀ Γ₂ ζ, WtSub Γ₁ Γ₂ ζ → ⟪ Γ₂ i⊢ t[ζ] : T ⟫.
Proof. induction wt; crush. Qed.
#[export]
Hint Resolve typing_sub : ws.

Lemma wtSub_comp {Γ₁ Γ₂ Γ₃ ζ₁ ζ₂} :
  WtSub Γ₁ Γ₂ ζ₁ → WtSub Γ₂ Γ₃ ζ₂ → WtSub Γ₁ Γ₃ (ζ₁ >=> ζ₂).
Proof. unfold WtSub, comp; eauto with ws. Qed.
#[export]
Hint Resolve wtSub_comp : ws.

Lemma wtiTm_snoc Γ₁ Γ₂ ζ T t :
  WtSub (Γ₁ r▻ T) Γ₂ (ζ · t) → ⟪ Γ₂ i⊢ t : T ⟫.
Proof.
  intros wζ. specialize (wζ 0). eauto using GetEvar.
Qed.
#[export]
Hint Resolve wtiTm_snoc : wsi.

(*************************************************************************)

Lemma wtSub_beta (Γ Δ: Env) :
  ∀ ζ, WtSub Δ Γ ζ → WtSub (Γ r▻▻ Δ) Γ (beta (dom Δ) ζ).
Proof.
  unfold WtSub; induction Δ; crush.
Qed.
#[export]
Hint Resolve wtSub_beta : ws.

Lemma wtSub_beta1 Γ t T (wi: ⟪ Γ i⊢ t : T ⟫) :
  WtSub (Γ r▻ T) Γ (beta1 t).
Proof. apply (wtSub_beta Γ (empty r▻ T)); crush. Qed.
#[export]
Hint Resolve wtSub_beta1 : ws.

(*************************************************************************)

(* Lemma typing_beta {Γ Δ t T ζ} : *)
(*   WtSub Δ Γ ζ → ⟪ (Γ ▻▻ Δ) ⊢ t : T ⟫ → ⟪ Γ ⊢ t[beta (dom Δ) ζ] : T ⟫. *)
(* Proof. intros; eapply typing_sub; eauto with ws. Qed. *)

(* Lemma typing_beta1 {Γ t T t' T'} : *)
(*   ⟪ Γ ⊢ t' : T' ⟫ → ⟪ Γ ▻ T' ⊢ t : T ⟫ → ⟪ Γ ⊢ t[beta1 t'] : T ⟫. *)
(* Proof. intros; eapply typing_sub; eauto with ws. Qed. *)

(*************************************************************************)

Ltac crushTypingMatchH2 :=
  match goal with
    | [ |- ⟪ _ i⊢ @ap Tm Ix vrIx _ ?ξ ?t : _ ⟫
      ] => eapply typing_ren
    | [ |- ⟪ _ i⊢ @ap Tm Tm vrTm _ ?ζ ?t : _ ⟫
      ] => eapply typing_sub
    | [ |- WtSub (_ r▻ _) _ (beta _ _)
      ] => eapply wtSub_beta
    | [ |- WtSub (_ r▻ _) _ (beta1 _)
      ] => eapply wtSub_beta1
  end.

#[export]
Hint Resolve pctxtyping_cat : typing.
#[export]
Hint Resolve pctxtyping_app : typing.

Lemma wtvar_implies_wsvar {Γ i τ} :
  ⟪ i : τ r∈ Γ ⟫ → dom Γ ∋ i.
Proof.
  induction 1; eauto with ws.
Qed.

Lemma wt_implies_ws {Γ t τ} :
  ⟪ Γ i⊢ t : τ ⟫ → ⟨ dom Γ ⊢ t ⟩.
Proof.
  induction 1; constructor;
  eauto using wtvar_implies_wsvar with ws.
Qed.

(* (* We want a simple way of proving that types are closed under reasonable circumstances (closed environments, etc.). *)

(*  This proof should be nasty and require us to insert various changes into the basic structures (i.e. the abs term constructor will require proof that the argument type is closed), so we admit for now as it is obviously valid (with the appropriate changes to terms and environments) and tangential to the rest of the proof. *) *)
(* Lemma typed_terms_are_closed {Γ} (t : Tm) (T : Ty) : *)
(*   (* ClosedEnv Γ → *) (* will need this later, but for now it makes our life difficult as we don't have the mechanisms to easily prove this fact about environments *) *)
(*   ⟪ Γ i⊢ t : T ⟫ → *)
(*   ClosedTy T. *)
(* Proof. *)
(*   intros. *)
(*   induction H. *)
(* Admitted. *)
(* (*   inversion τ. *) *)
(* (*   induction τ. *) *)
(* (*   crushTypingMatchH. *) *)
(* (*   induction H. *) *)
(* (*   induction τ. *) *)
(* (*   rewrite H2 in IHτ1. *) *)
(* (*   rewrite H2 in IHτ2. *) *)
(* (* Admitted. *) *)
Lemma typed_terms_are_valid {Γ} (t : Tm) (T : Ty) :
  ValidEnv Γ →
  ⟪ Γ i⊢ t : T ⟫ →
  ValidTy T.
Proof.
  intros cenv wt.
  induction wt; eauto with wt tyvalid.
  - specialize (IHwt1 cenv).
    now eapply ValidTy_invert_arr in IHwt1.
  - specialize (IHwt cenv).
    now eapply ValidTy_invert_prod in IHwt.
  - specialize (IHwt cenv).
    now eapply ValidTy_invert_prod in IHwt.
  - specialize (IHwt cenv).
    now eapply ValidTy_unfold_trec in IHwt.
Qed.

Ltac try_typed_terms_are_valid :=
  match goal with
  | [ H: ⟪ _ i⊢ _ : ?τ ⟫ |- ValidTy ?τ ] => refine (typed_terms_are_valid _ _ _ H)
  end.

#[export]
Hint Extern 50 (ValidTy _) => try_typed_terms_are_valid : tyvalid_terms.

Lemma invert_ty_abs {Γ τ₁ t τ} :
  ValidEnv Γ ->
  ⟪ Γ i⊢ abs τ₁ t : τ ⟫ ->
  exists τ₂, ValidTy τ₁ /\ ValidTy τ₂ /\
          (τ₁ r⇒ τ₂) = τ ∧
          ⟪ Γ r▻ τ₁ i⊢ t : τ₂ ⟫.
Proof.
  intros vΓ wt.
  depind wt.
  exists τ₂;
  split; eauto using typed_terms_are_valid with tyeq tyvalid.
Qed.

Lemma invert_ty_proj₁ {Γ t τ} :
  ValidEnv Γ ->
  ⟪ Γ i⊢ proj₁ t : τ ⟫ ->
  exists τ₂, ⟪ Γ i⊢ t : τ r× τ₂ ⟫.
Proof.
  intros vΓ wt.
  depind wt.
  now exists τ₂.
Qed.

Lemma invert_ty_proj₂ {Γ t τ} :
  ValidEnv Γ ->
  ⟪ Γ i⊢ proj₂ t : τ ⟫ ->
  exists τ₁, ⟪ Γ i⊢ t : τ₁ r× τ ⟫.
Proof.
  intros vΓ wt.
  depind wt.
  now exists τ₁.
Qed.

Lemma invert_ty_pair {Γ t₁ t₂ τ₁ τ₂} :
  ValidEnv Γ ->
  ⟪ Γ i⊢ pair t₁ t₂ : τ₁ r× τ₂ ⟫ ->
  ValidTy τ₁ ∧ ValidTy τ₂ /\ ⟪ Γ i⊢ t₁ : τ₁ ⟫ /\ ⟪ Γ i⊢ t₂ : τ₂ ⟫.
Proof.
  intros vΓ wt.
  depind wt.
  split; eauto using typed_terms_are_valid with tyeq tyvalid.
Qed.

Lemma invert_ty_app {Γ t₁ t₂ τ} :
  ValidEnv Γ ->
  ⟪ Γ i⊢ app t₁ t₂ : τ ⟫ ->
  exists τ₁, ⟪ Γ i⊢ t₁ : τ₁ r⇒ τ ⟫ /\ ⟪ Γ i⊢ t₂ : τ₁ ⟫.
Proof.
  intros vΓ wt.
  depind wt.
  exists τ₁. assert (vτ₁ := typed_terms_are_valid _ _ vΓ wt1).
  now eapply ValidTy_invert_arr in vτ₁.
Qed.

Lemma invert_ty_caseof {Γ t₁ t₂ t₃ τ} :
  ⟪ Γ i⊢ caseof t₁ t₂ t₃ : τ ⟫ ->
  exists τ₁ τ₂, ⟪ Γ i⊢ t₁ : τ₁ r⊎ τ₂ ⟫ /\ ⟪ Γ r▻ τ₁ i⊢ t₂ : τ ⟫ /\ ⟪ Γ r▻ τ₂ i⊢ t₃ : τ ⟫.
Proof.
  intros wt.
  depind wt.
  now exists τ₁, τ₂.
Qed.

Lemma invert_ty_inl {Γ t τ₁ τ₂} :
  ValidEnv Γ ->
  ⟪ Γ i⊢ inl t : τ₁ r⊎ τ₂ ⟫ ->
  ValidTy τ₁ /\ ValidTy τ₂ /\ ⟪ Γ i⊢ t : τ₁ ⟫.
Proof.
  intros vΓ wt.
  depind wt.
  split; eauto using typed_terms_are_valid with tyeq tyvalid.
Qed.

Lemma invert_ty_inr {Γ t τ₁ τ₂} :
  ValidEnv Γ ->
  ⟪ Γ i⊢ inr t : τ₁ r⊎ τ₂ ⟫ ->
  ValidTy τ₁ /\ ValidTy τ₁ /\ ⟪ Γ i⊢ t : τ₂ ⟫.
Proof.
  intros vΓ wt.
  depind wt.
  split; eauto using typed_terms_are_valid with tyeq tyvalid.
Qed.

Lemma invert_ty_ite {Γ t₁ t₂ t₃ τ} :
  ⟪ Γ i⊢ ite t₁ t₂ t₃ : τ ⟫ ->
  ⟪ Γ i⊢ t₁ : tbool ⟫ /\ ⟪ Γ i⊢ t₂ : τ ⟫ /\ ⟪ Γ i⊢ t₃ : τ ⟫.
Proof.
  intros wt.
  depind wt.
  eauto.
Qed.

Lemma invert_ty_seq {Γ t₁ t₂ τ} :
  ⟪ Γ i⊢ seq t₁ t₂ : τ ⟫ ->
  ⟪ Γ i⊢ t₁ : tunit ⟫ /\ ⟪ Γ i⊢ t₂ : τ ⟫.
Proof.
  intros wt.
  depind wt.
  eauto.
Qed.

Lemma invert_ty_fold {Γ t τ} :
  ⟪ Γ i⊢ fold_ t : trec τ ⟫ →
  ValidTy (trec τ) ∧ ⟪ Γ i⊢ t : τ[beta1 (trec τ)] ⟫.
Proof.
  intros wt.
  depind wt.
  eauto.
Qed.

Lemma invert_ty_unfold {Γ t τ} :
  ⟪ Γ i⊢ unfold_ t : τ ⟫ →
  exists τ', ValidTy (trec τ') ∧
          τ = τ'[beta1 (trec τ')] ∧
          ⟪ Γ i⊢ t : trec τ' ⟫.
Proof.
  intros wt.
  depind wt.
  exists τ; split; eauto using typed_terms_are_valid with tyeq tyvalid.
Qed.

Ltac crushTypingMatchHInv :=
  match goal with
    (* | H: ⟪ _ e⊢ var _        : _ ⟫ |- _ => inversion H; clear H *)
    | H2: ValidEnv ?Γ, H: ⟪ _ i⊢ abs _ _      : _ ⟫ |- _ => destruct (invert_ty_abs H2 H) as (? & ? & ? & eq & ?); inversion eq; subst; clear H
    | H2: ValidEnv ?Γ, H: ⟪ ?Γ i⊢ app _ _      : _ ⟫ |- _ => destruct (invert_ty_app H2 H) as (? & ? & ?); clear H
    (* | H: ⟪ _ e⊢ unit         : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ e⊢ true         : _ ⟫ |- _ => inversion H; clear H *)
    (* | H: ⟪ _ e⊢ false        : _ ⟫ |- _ => inversion H; clear H *)
    | H: ⟪ _ i⊢ ite _ _ _    : _ ⟫ |- _ => destruct (invert_ty_ite H) as (? & ? & ?); clear H
    | H2: ValidEnv ?Γ, H: ⟪ _ i⊢ proj₁ _      : _ ⟫ |- _ => destruct (invert_ty_proj₁ H2 H) as (? & ?); clear H
    | H2: ValidEnv ?Γ, H: ⟪ _ i⊢ proj₂ _      : _ ⟫ |- _ => destruct (invert_ty_proj₂ H2 H) as (? & ?); clear H
    | H2: ValidEnv ?Γ, H: ⟪ _ i⊢ pair _ _      : _ ⟫ |- _ => destruct (invert_ty_pair H2 H) as (? & ? & ? & ?); clear H
    | H2: ValidEnv ?Γ, H: ⟪ _ i⊢ inl _        : _ ⟫ |- _ => destruct (invert_ty_inl H2 H) as (? & ? & ?); clear H
    | H2: ValidEnv ?Γ, H: ⟪ _ i⊢ inr _        : _ ⟫ |- _ => destruct (invert_ty_inr H2 H) as (? & ? & ?); clear H
    | H: ⟪ _ i⊢ caseof _ _ _ : _ ⟫ |- _ => destruct (invert_ty_caseof H) as (? & ? & ? & ? & ?); clear H
    | H: ⟪ _ i⊢ seq _ _      : _ ⟫ |- _ => destruct (invert_ty_seq H) as (? & ?); clear H
    | H: ⟪ _ i⊢ fold_ _      : _ ⟫ |- _ => destruct (invert_ty_fold H) as (? & ?); clear H
    | H: ⟪ _ i⊢ unfold_ _      : _ ⟫ |- _ => destruct (invert_ty_unfold H) as (? & ? & eq & ?); inversion eq; subst; clear H
  end.

Ltac crushTyping :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushRecTypesMatchH;
     repeat crushStlcSyntaxMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasMatchH;
     repeat crushTypingMatchH;
     repeat crushTypingMatchHInv;
     repeat crushTypingMatchH2
    );
  eauto with ws tyvalid tyeq.

(* Ltac crushTyping := *)
(*   intros; cbn in * |-; *)
(*   repeat *)
(*     (cbn; *)
(*      repeat crushRecTypesMatchH; *)
(*      repeat crushStlcSyntaxMatchH; *)
(*      repeat crushDbSyntaxMatchH; *)
(*      repeat crushDbLemmasMatchH; *)
(*      repeat crushTypingMatchH; *)
(*      repeat crushTypingMatchH2; *)
(*      eauto with ws *)
(*     ). *)

#[export]
Hint Extern 20 (⟪ _ i⊢ _ : _ ⟫) =>
  crushTyping : typing.

#[export]
Hint Extern 20 (⟪ i⊢ _ : _ , _ → _ , _ ⟫) =>
  crushTyping : typing.


(** Generic support for writing (privileged) concrete machine programs. *)

Require Import ZArith.
Require Import List.
Require Import Utils.
Import ListNotations.

Require Import Instr.

Local Open Scope Z_scope.
Set Implicit Arguments.

Section CodeGeneration.

Definition code := list Instr.

(* Utility operations *)
(* now a real instruction: Definition pop: code := [BranchNZ 1]. *)
Definition pop : code := [Pop].  (* for backward compatibility. *)
(* still a real instruction (why?): Definition nop: code := []. *)
Definition nop := [Noop].
Definition push v: code := [Push v].
Definition push_cptr ofs: code := [PushCachePtr] ++ [Push ofs] ++ [Add].

Definition storeAt loc :=
  push_cptr loc ++ [Store].

Definition loadFromCache loc: code :=
  push_cptr loc ++ [Load].

(* ---------------------------------------------------------------- *)
(* Code generation with ease of proof in mind *)

(* Skip the next [n] instructions conditionally *)
Definition skipNZ (n : nat) : code :=
  (* Add 1 because [BranchNZ] counts from the *current* pc *)
  [BranchNZ (Z_of_nat (S n))].

(* Skip the next [n] instructions unconditionally *)
Definition skip (n : nat) : code :=
  (* Pointless append here makes it easier to apply [HT_compose] *)
  push 1 ++ skipNZ n.

(* Building block for if statement [ite] *)
Definition ifNZ t f :=
  let f' := f ++ skip (length t)
  in skipNZ (length f')
     ++ f'
     ++ t.

(* If statement: [if c then t else f] *)
Definition ite (c t f : code) : code :=
  c ++ ifNZ t f.

(* Case statement:

   (* cbs = (c1,bs) :: (c2,b2) :: ... *)
   if c1 then b1 else
   if c2 then b2 else
   ...
   if cn then bn else default

*)
Fixpoint cases (cbs : list (code * code)) (default: code) : code :=
  (* This is a foldr ... *)
  match cbs with
  | nil           => default
  | (c,b) :: cbs' => ite c b (cases cbs' default)
  end.

(* Version of [cases] with branches generated uniformly from
   indices:

   - [genC] generates branch guards.
   - [genB] generates branch bodies.

*)
Definition indexed_cases {I} (cnil: code) (genC genB: I -> code) (indices: list I): code :=
  cases (map (fun i => (genC i, genB i)) indices) cnil.

Definition genEq := [Eq].

(* Operations on booleans.  Not all of these are currently used. *)
(* Encoding of booleans: Vint 0 = False, <> Vint 0 = True *)

Definition boolToZ (b: bool): Z  := if b then 1 else 0.

Definition genFalse :=
  push (boolToZ false).

Definition genTrue :=
  push (boolToZ true).

Definition genAnd :=
  push 0 ++ genEq ++ ifNZ (pop ++ genFalse) nop.

Definition genOr :=
  push 0 ++ genEq ++ ifNZ nop (pop ++ genTrue).

Definition genNot :=
  push 0 ++ genEq.

Definition genImpl :=
  (* [a -> b \equiv ~a \/ b] *)
  genNot ++ genOr.

Definition some c: code := c ++ push 1.
Definition none:   code := push 0.

Definition sub: code := [Sub].

Definition genTestEqual (c1 c2: code): code :=
  c1 ++
  c2 ++
  genEq.

Definition dup := [Dup 0].

Definition swap := [Swap 1].

(* do c as along as top of stack is non-zero *)
Definition genLoop (c : code) : code :=
  c ++ dup ++ (BranchNZ (- (Z_of_nat (length (c ++ dup)))) :: nil).

(* do c until (top of stack = 0) *)
Definition genFor (c:code) :=
 dup ++ ifNZ (genLoop (c ++ push (-1) ++ [Add])) nop.

Definition genError := push (-1) ++ [Jump].

(* Expects an option on the stack, as encoded by the [some] and [none]
generators. If the element is a [some], returns that
element. Otherwise, causes an error. *)

Definition genSysRet : code := ifNZ [Ret] genError.
Definition genSysVRet : code := ifNZ [VRet] genError.

End CodeGeneration.


Require Import List.
Export ListNotations.

Require Import genT.
Require Import PeanoNat.
Require Import Lia.

Require Import Ensembles.
Require Import BiInt_GHC.
Require Import BiInt_logics.
Require Import BiInt_extens_interactions.
Require Import BiInt_remove_list.
Require Import wBIH_meta_interactions.

(* Some proof-theoretical results about list_disj. They are helpful in the manipulation
    of prime theories. *)

Lemma Id_list_disj : forall Γ l0 l1,
  wBIH_rules (Γ, list_disj l0 → list_disj (l0 ++ l1)).
Proof.
induction l0 ; intros.
- simpl. apply wEFQ.
- simpl. apply wmonotL_Or. apply IHl0.
Qed.

Lemma list_disj_app : forall l0 Γ A l1,
  wBIH_rules (Γ, A → list_disj (l0 ++ l1)) -> wBIH_rules (Γ, A → (Or (list_disj l0) (list_disj l1))).
Proof.
induction l0.
- simpl. intros.
  apply MP with (ps:=[(Γ, ((list_disj l1) → (Or (Bot V) (list_disj l1))) → (A → (Or (Bot V) (list_disj l1))));(Γ, (list_disj l1) → (Or (Bot V) (list_disj l1)))]).
  2: apply MPRule_I. intros. inversion H0. subst.
  apply MP with (ps:=[(Γ, (A → (list_disj l1)) → ((list_disj l1) → (Or (Bot V) (list_disj l1))) → (A → (Or (Bot V) (list_disj l1))));(Γ,A → (list_disj l1))]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Ax. apply AxRule_I. apply RA1_I.
  exists A. exists (list_disj l1). exists ((Or (Bot V) (list_disj l1))). auto. inversion H2.
  2: inversion H3. subst. assumption. inversion H1. 2: inversion H2. subst. apply Ax.
  apply AxRule_I. apply RA3_I. exists (Bot V). exists (list_disj l1). auto.
- simpl. intros.
  apply MP with (ps:=[(Γ, ((Or a (list_disj (l0 ++ l1))) → ((Or (Or a (list_disj l0))) (list_disj l1))) → (A → ((Or (Or a (list_disj l0))) (list_disj l1))));
  (Γ,  ((Or a (list_disj (l0 ++ l1))) → ((Or (Or a (list_disj l0))) (list_disj l1))))]).
  2: apply MPRule_I. intros. inversion H0. subst.
  apply MP with (ps:=[(Γ, (A → (Or a (list_disj (l0 ++ l1)))) → ((Or a (list_disj (l0 ++ l1))) → ((Or (Or a (list_disj l0))) (list_disj l1))) → (A → ((Or (Or a (list_disj l0))) (list_disj l1))));
  (Γ,  A → (Or a (list_disj (l0 ++ l1))))]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Ax. apply AxRule_I. apply RA1_I.
  exists A. exists ((Or a (list_disj (l0 ++ l1)))). exists (((Or (Or a (list_disj l0))) (list_disj l1))).
  auto. inversion H2. 2: inversion H3. subst. auto. inversion H1. 2: inversion H2.
  subst.
  apply MP with (ps:=[(Γ, ((Or a (Or (list_disj l0) (list_disj l1))) → ((Or (Or a (list_disj l0))) (list_disj l1))) → ((Or a (list_disj (l0 ++ l1))) → ((Or (Or a (list_disj l0))) (list_disj l1))));
  (Γ, ((Or a (Or (list_disj l0) (list_disj l1))) → ((Or (Or a (list_disj l0))) (list_disj l1))))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MP with (ps:=[(Γ, ((Or a (list_disj (l0 ++ l1))) → (Or a (Or (list_disj l0) (list_disj l1)))) → ((Or a (Or (list_disj l0) (list_disj l1))) → ((Or (Or a (list_disj l0))) (list_disj l1))) → ((Or a (list_disj (l0 ++ l1))) → ((Or (Or a (list_disj l0))) (list_disj l1))));
  (Γ, ((Or a (list_disj (l0 ++ l1))) → (Or a (Or (list_disj l0) (list_disj l1)))))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I.
  apply RA1_I. exists ((Or a (list_disj (l0 ++ l1)))). exists ((Or a (Or (list_disj l0) (list_disj l1)))).
  exists (((Or (Or a (list_disj l0))) (list_disj l1))). auto. inversion H4. 2: inversion H5.
  subst. apply wmonotL_Or. apply IHl0. apply wimp_Id_gen. inversion H3. 2: inversion H4. subst.
  remember (list_disj l0) as E. remember (list_disj l1) as F.
  apply MP with (ps:=[(Γ, ((Or E F) → (Or (Or a E) F)) → ((Or a (Or E F)) → (Or (Or a E) F)));
  (Γ, ((Or E F) → (Or (Or a E) F)))]). 2: apply MPRule_I. intros. inversion H4. rewrite <- H5.
  apply MP with (ps:=[(Γ, (a → (Or (Or a E) F)) → ((Or E F) → (Or (Or a E) F)) → ((Or a (Or E F)) → (Or (Or a E) F)));
  (Γ, (a → (Or (Or a E) F)))]). 2: apply MPRule_I. intros. inversion H6. rewrite <- H7.
  apply Ax. apply AxRule_I. apply RA4_I. exists a. exists (Or E F). exists ((Or (Or a E) F)).
  auto. inversion H7. 2: inversion H8. rewrite <- H8.
  apply MP with (ps:=[(Γ, ((Or a E) → (Or (Or a E) F)) → (a → (Or (Or a E) F)));(Γ, ((Or a E) → (Or (Or a E) F)))]).
  2: apply MPRule_I. intros. inversion H9. rewrite <- H10.
  apply MP with (ps:=[(Γ, (a → (Or a E)) → ((Or a E) → (Or (Or a E) F)) → (a → (Or (Or a E) F)));(Γ, a → (Or a E))]).
  2: apply MPRule_I. intros. inversion H11. rewrite <- H12. apply Ax. apply AxRule_I.
  apply RA1_I. exists a. exists (Or a E). exists ((Or (Or a E) F)). auto.
  inversion H12. 2: inversion H13. rewrite <- H13. apply Ax. apply AxRule_I. apply RA2_I.
  exists a. exists E. auto. inversion H10. 2: inversion H11. rewrite <- H11. apply Ax.
  apply AxRule_I. apply RA2_I. exists (Or a E). exists F. auto. inversion H5. 2: inversion H6.
  rewrite <- H6. apply wmonotR_Or. apply Ax. apply AxRule_I. apply RA3_I. exists a. exists E. auto.
Qed.

Lemma list_disj_app0 : forall l0 Γ A l1,
  wBIH_rules (Γ, A → (Or (list_disj l0) (list_disj l1))) -> wBIH_rules (Γ, A → list_disj (l0 ++ l1)).
Proof.
induction l0.
- simpl. intros.
  apply MP with (ps:=[(Γ, ((Or (Bot V) (list_disj l1)) → list_disj l1) → (A → list_disj l1));
  (Γ, (Or (Bot V) (list_disj l1)) → list_disj l1)]). 2: apply MPRule_I. intros. inversion H0. subst.
  apply MP with (ps:=[(Γ, (A → (Or (Bot V) (list_disj l1))) → ((Or (Bot V) (list_disj l1)) → list_disj l1) → (A → list_disj l1));
  (Γ, A → (Or (Bot V) (list_disj l1)))]). 2: apply MPRule_I. intros. inversion H1. subst.
  apply Ax. apply AxRule_I. apply RA1_I. exists A. exists ((Or (Bot V) (list_disj l1))).
  exists (list_disj l1). auto. inversion H2. 2: inversion H3. subst. auto. inversion H1.
  2: inversion H2. subst.
  apply MP with (ps:=[(Γ, ((list_disj l1) → list_disj l1) → ((Or (Bot V) (list_disj l1)) → list_disj l1));
  (Γ, (list_disj l1) → list_disj l1)]). 2: apply MPRule_I. intros. inversion H2. subst.
  apply MP with (ps:=[(Γ, ((Bot V) → list_disj l1) → ((list_disj l1) → list_disj l1) → ((Or (Bot V) (list_disj l1)) → list_disj l1));
  (Γ, (Bot V) → list_disj l1)]). 2: apply MPRule_I. intros. inversion H3. subst.
  apply Ax. apply AxRule_I. apply RA4_I. exists (Bot V). exists (list_disj l1).
  exists (list_disj l1). auto. inversion H4. 2: inversion H5. subst. apply wEFQ.
  inversion H3. 2: inversion H4. subst. apply wimp_Id_gen.
- simpl. intros.
  apply MP with (ps:=[(Γ, (((Or (Or a (list_disj l0))) (list_disj l1)) → (Or a (list_disj (l0 ++ l1)))) → (A → (Or a (list_disj (l0 ++ l1)))));
  (Γ, (((Or (Or a (list_disj l0))) (list_disj l1)) → (Or a (list_disj (l0 ++ l1)))))]).
  2: apply MPRule_I. intros. inversion H0. subst.
  apply MP with (ps:=[(Γ, (A → ((Or (Or a (list_disj l0))) (list_disj l1))) → (((Or (Or a (list_disj l0))) (list_disj l1)) → (Or a (list_disj (l0 ++ l1)))) → (A → (Or a (list_disj (l0 ++ l1)))));
  (Γ,  A → ((Or (Or a (list_disj l0))) (list_disj l1)))]).
  2: apply MPRule_I. intros. inversion H1. subst. apply Ax. apply AxRule_I. apply RA1_I.
  exists A. exists (((Or (Or a (list_disj l0))) (list_disj l1))). exists ((Or a (list_disj (l0 ++ l1)))).
  auto. inversion H2. 2: inversion H3. subst. auto. inversion H1. 2: inversion H2.
  subst.
  apply MP with (ps:=[(Γ, ((Or a (Or (list_disj l0) (list_disj l1))) → (Or a (list_disj (l0 ++ l1)))) → (((Or (Or a (list_disj l0))) (list_disj l1)) → (Or a (list_disj (l0 ++ l1)))));
  (Γ, ((Or a (Or (list_disj l0) (list_disj l1))) → (Or a (list_disj (l0 ++ l1)))))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MP with (ps:=[(Γ, (((Or (Or a (list_disj l0))) (list_disj l1)) → (Or a (Or (list_disj l0) (list_disj l1)))) → ((Or a (Or (list_disj l0) (list_disj l1))) → (Or a (list_disj (l0 ++ l1)))) → (((Or (Or a (list_disj l0))) (list_disj l1)) → (Or a (list_disj (l0 ++ l1)))));
  (Γ, (((Or (Or a (list_disj l0))) (list_disj l1)) → (Or a (Or (list_disj l0) (list_disj l1)))))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I.
  apply RA1_I. exists (((Or (Or a (list_disj l0))) (list_disj l1))).
  exists ((Or a (Or (list_disj l0) (list_disj l1)))). exists ((Or a (list_disj (l0 ++ l1)))).
  auto. inversion H4. 2: inversion H5.
  subst. remember (list_disj l0) as E. remember (list_disj l1) as F.
  apply MP with (ps:=[(Γ, (F → (Or a (Or E F))) → ((Or (Or a E) F) → (Or a (Or E F))));
  (Γ, F → (Or a (Or E F)))]). 2: apply MPRule_I. intros. inversion H5. rewrite <- H6.
  apply MP with (ps:=[(Γ, ((Or a E) → (Or a (Or E F))) → (F → (Or a (Or E F))) → ((Or (Or a E) F) → (Or a (Or E F))));
  (Γ, ((Or a E) → (Or a (Or E F))))]). 2: apply MPRule_I. intros. inversion H7. rewrite <- H8.
  apply Ax. apply AxRule_I. apply RA4_I. exists (Or a E). exists F. exists ((Or a (Or E F))).
  auto. inversion H8. 2: inversion H9. rewrite <- H9. apply wmonotL_Or. apply Ax.
  apply AxRule_I. apply RA2_I. exists E. exists F. auto. inversion H6. 2: inversion H7.
  rewrite <- H7.
  apply MP with (ps:=[(Γ, ((Or E F) → (Or a (Or E F))) → (F → (Or a (Or E F))));(Γ, ((Or E F) → (Or a (Or E F))))]).
  2: apply MPRule_I. intros. inversion H8. rewrite <- H9.
  apply MP with (ps:=[(Γ, (F → (Or E F)) → ((Or E F) → (Or a (Or E F))) → (F → (Or a (Or E F))));(Γ, F → (Or E F))]).
  2: apply MPRule_I. intros. inversion H10. rewrite <- H11. apply Ax. apply AxRule_I.
  apply RA1_I. exists F. exists (Or E F). exists ((Or a (Or E F))). auto.
  inversion H11. 2: inversion H12. rewrite <- H12. apply Ax. apply AxRule_I. apply RA3_I.
  exists E. exists F. auto. inversion H9. 2: inversion H10. rewrite <- H10. apply Ax.
  apply AxRule_I. apply RA3_I. exists a. exists (Or E F). auto. inversion H3. 2: inversion H4.
  rewrite <- H4. apply wmonotL_Or. apply IHl0. apply wimp_Id_gen.
Qed.

Notation "A ∨ B" := (Or A B) (at level 13, right associativity) : My_scope.

Lemma list_disj_remove_app : forall l0 l1 Γ A,
wBIH_rules (Γ, list_disj (l0 ++ remove_list l0 l1) → (Or A (list_disj (l0 ++ remove eq_dec_form A (remove_list l0 l1))))).
Proof.
induction l0.
- simpl. intros. apply remove_disj.
- simpl. intros.
  apply MP with (ps:=[(Γ, (a ∨ (A ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))
  → A ∨ (a ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))) → (a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))
  → A ∨ (a ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))));
  (Γ,a ∨ (A ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))
  → A ∨ (a ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1))))))]).
  2: apply MPRule_I. intros. inversion H. subst.
  apply MP with (ps:=[(Γ, (a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))
  → a ∨ (A ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))) → (a ∨ (A ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))
  → A ∨ (a ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))) → (a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))
  → A ∨ (a ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))));
  (Γ,(a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))
  → a ∨ (A ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA1_I.
  exists (a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))).
  exists (a ∨ (A ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))).
  exists (A ∨ (a ∨ (list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1)))))). auto.
  inversion H1. 2: inversion H2. subst.
  { simpl. apply wmonotL_Or. clear H1. clear H0. clear H.
    remember (remove eq_dec_form a (remove_list l0 l1)) as E.
    apply MP with (ps:=[(Γ, (A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E))) → A ∨ (list_disj (l0 ++ remove eq_dec_form A E))) → (list_disj (l0 ++ E) → A ∨ (list_disj (l0 ++ remove eq_dec_form A E))));
    (Γ, (A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E))) → A ∨ (list_disj (l0 ++ remove eq_dec_form A E))))]).
    2: apply MPRule_I. intros. inversion H. rewrite <- H0.
    apply MP with (ps:=[(Γ, (list_disj (l0 ++ E) → A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E)))) → (A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E))) → A ∨ (list_disj (l0 ++ remove eq_dec_form A E))) → (list_disj (l0 ++ E) → A ∨ (list_disj (l0 ++ remove eq_dec_form A E))));
    (Γ, (list_disj (l0 ++ E) → A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E)))))]).
    2: apply MPRule_I. intros. inversion H1. rewrite <- H2. apply Ax. apply AxRule_I.
    apply RA1_I. exists (list_disj (l0 ++ E)). exists (A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E)))).
    exists (A ∨ (list_disj (l0 ++ remove eq_dec_form A E))). auto. inversion H2. rewrite <- H3.
    { simpl. apply MP with (ps:=[(Γ, (((list_disj l0) ∨ (A ∨ (list_disj (remove eq_dec_form A E)))) → A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E)))) → (list_disj (l0 ++ E) → A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E)))));
    (Γ, (((list_disj l0) ∨ (A ∨ (list_disj (remove eq_dec_form A E)))) → A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E)))))]).
    2: apply MPRule_I. intros. inversion H4. rewrite <- H5.
    apply MP with (ps:=[(Γ, (list_disj (l0 ++ E) → ((list_disj l0) ∨ (A ∨ (list_disj (remove eq_dec_form A E))))) → (((list_disj l0) ∨ (A ∨ (list_disj (remove eq_dec_form A E)))) → A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E)))) → (list_disj (l0 ++ E) → A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E)))));
    (Γ, (list_disj (l0 ++ E) → ((list_disj l0) ∨ (A ∨ (list_disj (remove eq_dec_form A E))))))]).
    2: apply MPRule_I. intros. inversion H6. rewrite <- H7. apply Ax. apply AxRule_I. apply RA1_I.
    exists (list_disj (l0 ++ E)). exists ((list_disj l0) ∨ (A ∨ (list_disj (remove eq_dec_form A E)))).
    exists (A ∨ ((list_disj l0) ∨ (list_disj (remove eq_dec_form A E)))). auto.
    inversion H7. 2: inversion H8. rewrite <- H8.
    { remember ((list_disj l0) ∨ (A ∨ (list_disj (remove eq_dec_form A E)))) as F.
      apply MP with (ps:=[(Γ, (((list_disj l0) ∨ (list_disj E)) → F) → (list_disj (l0 ++ E) → F));
      (Γ, (((list_disj l0) ∨ (list_disj E)) → F))]). 2: apply MPRule_I. intros.
      inversion H9. rewrite <- H10.
      apply MP with (ps:=[(Γ, (list_disj (l0 ++ E) → ((list_disj l0) ∨ (list_disj E))) → (((list_disj l0) ∨ (list_disj E)) → F) → (list_disj (l0 ++ E) → F));
      (Γ, list_disj (l0 ++ E) → ((list_disj l0) ∨ (list_disj E)))]). 2: apply MPRule_I. intros.
      inversion H11. rewrite <- H12. apply Ax. apply AxRule_I. apply RA1_I.
      exists (list_disj (l0 ++ E)). exists ((list_disj l0) ∨ (list_disj E)). exists F. auto.
      inversion H12. 2: inversion H13. rewrite <- H13. apply list_disj_app. apply wimp_Id_gen.
      inversion H10. 2: inversion H11. rewrite <- H11. clear H11. clear H10.
      clear H9. clear H8. clear H7. clear H6. clear H5. clear H0. clear H4.
      clear H3. clear H2. clear H1. clear H. rewrite HeqF. apply wmonotL_Or.
      apply remove_disj. }
    inversion H5. 2: inversion H6. rewrite <- H6. remember (list_disj l0) as D.
    remember (list_disj (remove eq_dec_form A E)) as F.
    apply MP with (ps:=[(Γ, (A ∨ F → A ∨ (D ∨ F)) → (D ∨ (A ∨ F) → A ∨ (D ∨ F)));(Γ, (A ∨ F) → A ∨ (D ∨ F))]).
    2: apply MPRule_I. intros. inversion H7. rewrite <- H8.
    apply MP with (ps:=[(Γ, (D → A ∨ (D ∨ F)) → (A ∨ F → A ∨ (D ∨ F)) → (D ∨ (A ∨ F) → A ∨ (D ∨ F)));(Γ, D → A ∨ (D ∨ F))]).
    2: apply MPRule_I. intros. inversion H9. rewrite <- H10. apply Ax. apply AxRule_I.
    apply RA4_I. exists D. exists (A ∨ F). exists (A ∨ (D ∨ F)). auto. inversion H10. 2: inversion H11.
    rewrite <- H11.
    apply MP with (ps:=[(Γ, ((D ∨ F) → A ∨ (D ∨ F)) → (D → A ∨ (D ∨ F)));(Γ, ((D ∨ F) → A ∨ (D ∨ F)))]).
    2: apply MPRule_I. intros. inversion H12. rewrite <- H13.
    apply MP with (ps:=[(Γ, (D → (D ∨ F)) → ((D ∨ F) → A ∨ (D ∨ F)) → (D → A ∨ (D ∨ F)));(Γ, D → (D ∨ F))]).
    2: apply MPRule_I. intros. inversion H14. rewrite <- H15. apply Ax. apply AxRule_I.
    apply RA1_I. exists D. exists (D ∨ F). exists (A ∨ (D ∨ F)). auto. inversion H15.
    rewrite <- H16. apply Ax. apply AxRule_I. apply RA2_I. exists D. exists F. auto.
    inversion H16. inversion H13. rewrite <- H14. apply Ax. apply AxRule_I. apply RA3_I.
    exists A. exists (D ∨ F). auto. inversion H14. inversion H8. rewrite <- H9.
    apply wmonotL_Or. apply Ax. apply AxRule_I. apply RA3_I. exists D. exists F. auto.
    inversion H9. }
    inversion H3. inversion H0. 2: inversion H1. rewrite <- H1. apply wmonotL_Or. apply list_disj_app0.
    apply wimp_Id_gen. }
  inversion H0. 2: inversion H1. subst.
  remember ((list_disj (l0 ++ remove eq_dec_form A (remove eq_dec_form a (remove_list l0 l1))))) as E.
  apply MP with (ps:=[(Γ, ((A ∨ E) → A ∨ (Or a E)) → (a ∨ (A ∨ E) → A ∨ (Or a E)));
  (Γ, ((A ∨ E) → A ∨ (Or a E)))]). 2: apply MPRule_I. intros. inversion H1. rewrite <- H2.
  apply MP with (ps:=[(Γ, (a → A ∨ (Or a E)) → ((A ∨ E) → A ∨ (Or a E)) → (a ∨ (A ∨ E) → A ∨ (Or a E)));
  (Γ, (a → A ∨ (Or a E)))]). 2: apply MPRule_I. intros. inversion H3. rewrite <- H4. clear H4.
  clear H2. apply Ax. apply AxRule_I. apply RA4_I. exists a. exists (A ∨ E).
  exists (A ∨ (Or a E)). auto. inversion H4. 2: inversion H5. rewrite <- H5.
  apply MP with (ps:=[(Γ, ((Or a E) → A ∨ (Or a E)) → (a → A ∨ (Or a E))); (Γ, ((Or a E) → A ∨ (Or a E)))]).
  2: apply MPRule_I. intros. inversion H6. rewrite <- H7.
  apply MP with (ps:=[(Γ, (a → (Or a E)) → ((Or a E) → A ∨ (Or a E)) → (a → A ∨ (Or a E))); (Γ, a → (Or a E))]).
  2: apply MPRule_I. intros. inversion H8. rewrite <- H9. apply Ax. apply AxRule_I. apply RA1_I.
  exists a. exists (Or a E). exists (A ∨ (Or a E)). auto. inversion H9.
  rewrite <- H10. 2: inversion H10. apply Ax. apply AxRule_I. apply RA2_I.
  exists a. exists E. auto. inversion H7. 2: inversion H8. rewrite <- H8.
  apply Ax. apply AxRule_I. apply RA3_I. exists A. exists (Or a E). auto.
  inversion H2. rewrite <- H3. apply wmonotL_Or. apply Ax. apply AxRule_I.
  apply RA3_I. exists a. exists E. auto. inversion H3.
Qed.

Lemma Id_list_disj_remove : forall Γ l0 l1,
  wBIH_rules (Γ, list_disj l1 → list_disj (l0 ++ remove_list l0 l1)).
Proof.
induction l0.
- intros. simpl. apply wimp_Id_gen.
- simpl. intros.
  apply MP with (ps:=[(Γ, (list_disj (l0 ++ remove_list l0 l1) → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))) → (list_disj l1 → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))));
  (Γ, list_disj (l0 ++ remove_list l0 l1) → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1))))]).
  2: apply MPRule_I. intros. inversion H. subst.
  apply MP with (ps:=[(Γ, (list_disj l1 → list_disj (l0 ++ remove_list l0 l1)) → (list_disj (l0 ++ remove_list l0 l1) → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))) → (list_disj l1 → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))));
  (Γ,list_disj l1 → list_disj (l0 ++ remove_list l0 l1))]).
  2: apply MPRule_I. intros. inversion H0. subst. apply Ax. apply AxRule_I.
  apply RA1_I. exists (list_disj l1). exists (list_disj (l0 ++ remove_list l0 l1)).
  exists (a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))). auto.
  inversion H1. 2: inversion H2. subst. apply IHl0. inversion H0. subst.
  clear H. clear H0. apply list_disj_remove_app. inversion H1.
Qed.

Lemma der_list_disj_remove1 : forall Γ A l0 l1,
    (wBIH_rules (Γ, A → list_disj l0)) ->
    (wBIH_rules (Γ, A → list_disj (l0 ++ remove_list l0 l1))).
Proof.
intros Γ A. induction l0.
- simpl. intros.
  apply MP with (ps:=[(Γ, ((Bot V) → list_disj l1) → (A → list_disj l1));
  (Γ, (Bot V) → list_disj l1)]). 2: apply MPRule_I. intros. inversion H0. subst.
  apply MP with (ps:=[(Γ, (A → (Bot V)) → ((Bot V) → list_disj l1) → (A → list_disj l1));
  (Γ, A → (Bot V))]). 2: apply MPRule_I. intros. inversion H1. subst. apply Ax.
  apply AxRule_I. apply RA1_I. exists A. exists (Bot V). exists (list_disj l1).
  auto. inversion H2. 2: inversion H3. subst. auto. inversion H1. 2: inversion H2.
  subst. apply wEFQ.
- intros. subst. simpl. simpl in H.
  apply MP with (ps:=[(Γ, (a ∨ (list_disj l0) → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))) → (A → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))));
  (Γ, (a ∨ (list_disj l0) → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))))]).
  2: apply MPRule_I. intros. inversion H0. subst.
  apply MP with (ps:=[(Γ, (A → a ∨ (list_disj l0)) → (a ∨ (list_disj l0) → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))) → (A → a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))));
  (Γ, A → a ∨ (list_disj l0))]). 2: apply MPRule_I. intros. inversion H1. subst.
  apply Ax. apply AxRule_I. apply RA1_I. exists A. exists (Or a (list_disj l0)).
  exists (a ∨ (list_disj (l0 ++ remove eq_dec_form a (remove_list l0 l1)))). auto.
  inversion H2. 2: inversion H3. subst. auto. inversion H1. 2: inversion H2.
  subst. clear H0. clear H1. apply wmonotL_Or. apply Id_list_disj.
Qed.

Lemma der_list_disj_remove2 : forall Γ A l0 l1,
    (wBIH_rules (Γ, A → list_disj l1)) ->
    (wBIH_rules (Γ, A → list_disj (l0 ++ remove_list l0 l1))).
Proof.
intros.
apply MP with (ps:=[(Γ, (list_disj l1 → (list_disj (l0 ++ (remove_list l0 l1)))) → (A → (list_disj (l0 ++ (remove_list l0 l1)))));
(Γ, (list_disj l1 → (list_disj (l0 ++ (remove_list l0 l1)))))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MP with (ps:=[(Γ, (A → list_disj l1) → (list_disj l1 → (list_disj (l0 ++ (remove_list l0 l1)))) → (A → (list_disj (l0 ++ (remove_list l0 l1)))));
(Γ, A → list_disj l1)]).
2: apply MPRule_I. intros. inversion H1. subst. apply Ax. apply AxRule_I.
apply RA1_I. exists A. exists (list_disj l1). exists (list_disj (l0 ++ (remove_list l0 l1))).
auto. inversion H2. 2 : inversion H3. subst. auto. inversion H1. subst. 2: inversion H2.
clear H0. clear H1.
apply MP with (ps:=[(Γ, ((list_disj (l0 ++ (remove_list l0 l1))) → (list_disj (l0 ++ (remove_list l0 l1)))) → (list_disj l1 → (list_disj (l0 ++ (remove_list l0 l1)))));
(Γ, (list_disj (l0 ++ (remove_list l0 l1))) → (list_disj (l0 ++ (remove_list l0 l1))))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MP with (ps:=[(Γ, (list_disj l1 → (list_disj (l0 ++ (remove_list l0 l1)))) → ((list_disj (l0 ++ (remove_list l0 l1))) → (list_disj (l0 ++ (remove_list l0 l1)))) → (list_disj l1 → (list_disj (l0 ++ (remove_list l0 l1)))));
(Γ, (list_disj l1 → (list_disj (l0 ++ (remove_list l0 l1)))))]).
2: apply MPRule_I. intros. inversion H1. subst. apply Ax. apply AxRule_I. apply RA1_I.
exists (list_disj l1). exists ((list_disj (l0 ++ (remove_list l0 l1)))).
exists (list_disj (l0 ++ (remove_list l0 l1))). auto. inversion H2.
2: inversion H3. subst. clear H1. clear H2. clear H0. apply Id_list_disj_remove.
inversion H1. 2: inversion H2. subst. clear H0. clear H1. apply wimp_Id_gen.
Qed.

Lemma absorp_Or2 : forall A Γ,
    (wBIH_rules (Γ, (Bot V) ∨ A)) ->
    (wBIH_rules (Γ, A)).
Proof.
intros A Γ D.
apply MP with (ps:=[(Γ, ((Bot V) ∨ A)→ A);(Γ, (Bot V) ∨ A)]).
2: apply MPRule_I. intros. inversion H. subst.
apply MP with (ps:=[(Γ, (A→ A)→ (((Bot V) ∨ A)→ A));(Γ, (A→ A))]).
2: apply MPRule_I. intros. inversion H0. subst.
apply MP with (ps:=[(Γ, ((Bot V)→ A)→ (A→ A)→ (((Bot V) ∨ A)→ A));(Γ, (Bot V)→ A)]).
2: apply MPRule_I. intros. inversion H1. subst.
apply Ax. apply AxRule_I. apply RA4_I. exists (Bot V). exists A.
exists A. auto. inversion H2. subst. apply wEFQ. inversion H1. inversion H3.
inversion H3. inversion H1. subst. apply wimp_Id_gen. inversion H2.
inversion H0. subst. assumption. inversion H1.
Qed.

Lemma der_list_disj_bot : forall l Γ,
  wBIH_rules (Γ, list_disj l) -> wBIH_rules (Γ, list_disj (remove eq_dec_form (Bot V) l)).
Proof.
induction l.
- simpl. intros ; auto.
- intros. simpl in H. simpl. destruct (eq_dec_form (Bot V) a).
  + subst. apply IHl. apply absorp_Or2 ; auto.
  + simpl. apply MP with (ps:=[(Γ, (a ∨ list_disj l) → (a ∨ list_disj (remove eq_dec_form (Bot V) l)));(Γ, a ∨ list_disj l)]).
     intros. 2: apply MPRule_I. inversion H0. subst.
     apply MP with (ps:=[(Γ, (list_disj l → a ∨ list_disj (remove eq_dec_form (Bot V) l)) → ((a ∨ list_disj l) → (a ∨ list_disj (remove eq_dec_form (Bot V) l))));
     (Γ, list_disj l → a ∨ list_disj (remove eq_dec_form (Bot V) l))]).
     intros. 2: apply MPRule_I. inversion H1. subst.
     apply MP with (ps:=[(Γ, (a → a ∨ list_disj (remove eq_dec_form (Bot V) l)) → (list_disj l → a ∨ list_disj (remove eq_dec_form (Bot V) l)) → ((a ∨ list_disj l) → (a ∨ list_disj (remove eq_dec_form (Bot V) l))));
     (Γ, a → a ∨ list_disj (remove eq_dec_form (Bot V) l))]).
     intros. 2: apply MPRule_I. inversion H2. subst. apply Ax. apply AxRule_I. apply RA4_I.
     exists a. exists (list_disj l). exists (a ∨ list_disj (remove eq_dec_form (Bot V) l)). auto. inversion H3 ; subst.
     2: inversion H4. apply Ax. apply AxRule_I. apply RA2_I. exists a. exists (list_disj (remove eq_dec_form (Bot V) l)). auto.
     inversion H2 ; subst. 2: inversion H3.
     apply MP with (ps:=[(Γ, (list_disj (remove eq_dec_form (Bot V) l) → a ∨ list_disj (remove eq_dec_form (Bot V) l)) → (list_disj l → a ∨ list_disj (remove eq_dec_form (Bot V) l)));
     (Γ, (list_disj (remove eq_dec_form (Bot V) l) → a ∨ list_disj (remove eq_dec_form (Bot V) l)))]). 2: apply MPRule_I.
     intros. inversion H3. subst.
     apply MP with (ps:=[(Γ, (list_disj l → list_disj (remove eq_dec_form (Bot V) l)) → (list_disj (remove eq_dec_form (Bot V) l) → a ∨ list_disj (remove eq_dec_form (Bot V) l)) → (list_disj l → a ∨ list_disj (remove eq_dec_form (Bot V) l)));
     (Γ, list_disj l → list_disj (remove eq_dec_form (Bot V) l))]). 2: apply MPRule_I.
     intros. inversion H4. subst. apply Ax. apply AxRule_I. apply RA1_I. exists (list_disj l).
     exists (list_disj (remove eq_dec_form (Bot V) l)). exists (a ∨ list_disj (remove eq_dec_form (Bot V) l)). auto.
     inversion H5. subst. apply wBIH_Deduction_Theorem with (s:=(Union _ Γ (Singleton _ (list_disj l)), list_disj (remove eq_dec_form (Bot V) l))) ; auto.
     apply IHl. apply Id. apply IdRule_I. apply Union_intror. apply In_singleton. inversion H6.
     inversion H4. subst. 2: inversion H5. apply Ax. apply AxRule_I. apply RA3_I. exists a.
     exists (list_disj (remove eq_dec_form (Bot V) l)). auto. inversion H1. subst. 2: inversion H2. auto.
Qed.

Lemma list_disj_remove__ : forall l Γ A,
  wBIH_rules (Γ, list_disj l) -> wBIH_rules (Γ, A ∨ list_disj (remove eq_dec_form A l)).
Proof.
intros. pose (remove_disj l A Γ).
apply wBIH_Detachment_Theorem with (A:= list_disj l) (B:=A ∨ list_disj (remove eq_dec_form A l)) (Γ:=Γ) in w ; auto.
pose (wBIH_comp _ w Γ). apply w0. intros. simpl in H0. inversion H0 ; subst.
apply Id. apply IdRule_I. auto. inversion H1. subst. auto.
Qed.

Lemma list_disj_In0 : forall l Γ A,
  List.In A l ->
  wBIH_rules (Γ, A → list_disj l).
Proof.
induction l.
- intros. inversion H.
- intros. inversion H.
  * subst. simpl. apply Ax. apply AxRule_I. apply RA2_I. exists A. exists (list_disj l). auto.
  * simpl. apply MP with (ps:=[(Γ, (list_disj l → a ∨ list_disj l) → (A → a ∨ list_disj l));(Γ, (list_disj l → a ∨ list_disj l))]).
    2: apply MPRule_I. intros. inversion H1. subst.
    apply MP with (ps:=[(Γ, (A → list_disj l) → (list_disj l → a ∨ list_disj l) → (A → a ∨ list_disj l));(Γ, (A → list_disj l))]).
    2: apply MPRule_I. intros. inversion H2. subst.
    apply Ax. apply AxRule_I. apply RA1_I. exists A. exists (list_disj l). exists (a ∨ list_disj l). auto. inversion H3.
    subst. 2: inversion H4. apply IHl ; auto. inversion H2. subst. apply Ax. apply AxRule_I. apply RA3_I. exists a. exists (list_disj l). auto.
    inversion H3.
Qed.

Lemma list_disj_In : forall l Γ A,
  List.In A l ->
  wBIH_rules (Γ, A ∨ list_disj l) ->
  wBIH_rules (Γ,list_disj l).
Proof.
induction l.
- simpl. intros. inversion H.
- intros. simpl. simpl in H0.
  apply MP with (ps:=[(Γ, (A ∨ (a ∨ list_disj l)) → (a ∨ list_disj l));(Γ, A ∨ (a ∨ list_disj l))]).
  2: apply MPRule_I. intros. inversion H1. 2: inversion H2 ; subst ; auto. 2: inversion H3. subst.
  apply MP with (ps:=[(Γ, ((a ∨ list_disj l) → (a ∨ list_disj l)) → ((A ∨ (a ∨ list_disj l)) → (a ∨ list_disj l)));(Γ, (a ∨ list_disj l) → (a ∨ list_disj l))]).
  2: apply MPRule_I. intros. inversion H2. subst.
  apply MP with (ps:=[(Γ, (A → (a ∨ list_disj l)) → ((a ∨ list_disj l) → (a ∨ list_disj l)) → ((A ∨ (a ∨ list_disj l)) → (a ∨ list_disj l)));(Γ, A → (a ∨ list_disj l))]).
  2: apply MPRule_I. intros. inversion H3. subst. apply Ax. apply AxRule_I. apply RA4_I. exists A. exists (a ∨ list_disj l ). exists (a ∨ list_disj l ). auto.
  inversion H4. subst. 2: inversion H5.
  inversion H. subst. apply Ax. apply AxRule_I. apply RA2_I. exists A. exists (list_disj l). auto.
  apply MP with (ps:=[(Γ, (list_disj l → a ∨ list_disj l) → (A → a ∨ list_disj l));(Γ, (list_disj l → a ∨ list_disj l))]).
  2: apply MPRule_I. intros. inversion H6. subst.
  apply MP with (ps:=[(Γ, (A → list_disj l) → (list_disj l → a ∨ list_disj l) → (A → a ∨ list_disj l));(Γ, (A → list_disj l))]).
  2: apply MPRule_I. intros. inversion H7. subst. apply Ax. apply AxRule_I. apply RA1_I. exists A.
  exists (list_disj l). exists (a ∨ list_disj l). auto. inversion H8. subst. apply list_disj_In0 ; auto. inversion H9.
  inversion H7. subst. apply Ax. apply AxRule_I. apply RA3_I. exists a. exists (list_disj l). auto. inversion H8.
  inversion H3. subst. 2: inversion H4. apply wimp_Id_gen.
Qed.

(* ------------------------------------------------------------------------------------------------------ *)

(* Some proof-theoretical results about list_conj. *)

Fixpoint list_conj (l : list _) : BPropF V :=
match l with
 | nil => Top V
 | h :: t => And h (list_conj t)
end.

Notation "A ∧ B" := (And A B) (at level 13, right associativity) : My_scope.

Lemma list_conj_in_list : forall Γ l A,
  List.In A l ->
  wBIH_rules (Γ, (list_conj l) → A).
Proof.
induction l.
- intros. inversion H.
- intros. simpl. inversion H. subst. apply Ax. apply AxRule_I. apply RA5_I.
  exists A. exists (list_conj l). auto. apply IHl in H0.
  apply MP with (ps:=[(Γ, (list_conj l → A) → (a ∧ list_conj l → A));(Γ, list_conj l → A)]).
  2: apply MPRule_I. intros. inversion H1. subst.
  apply MP with (ps:=[(Γ, (a ∧ list_conj l → list_conj l) → (list_conj l → A) → (a ∧ list_conj l → A));(Γ, a ∧ list_conj l → list_conj l)]).
  2: apply MPRule_I. intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA1_I.
  exists (a ∧ list_conj l). exists (list_conj l). exists A. auto. inversion H3. subst.
  apply Ax. apply AxRule_I. apply RA6_I. exists a. exists (list_conj l). auto. inversion H4.
  inversion H2. subst. auto. inversion H3.
Qed.

Lemma finite_context_list_conj : forall Γ A,
  wBIH_rules (Γ, A) ->
  (forall l, (forall A : _, (Γ A -> List.In A l) * (List.In A l -> Γ A)) ->
  wBIH_rules (Singleton _ (list_conj l), A)).
Proof.
intros. pose (wBIH_comp _ H (Singleton _ (list_conj l))). apply w. intros. clear w.
simpl in H1.
apply MP with (ps:=[(Singleton _ (list_conj l), (list_conj l) → A0);(Singleton _ (list_conj l), list_conj l)]).
2: apply MPRule_I. intros. inversion H2. subst. apply list_conj_in_list. apply H0. auto.
inversion H3. subst. 2: inversion H4. apply Id. apply IdRule_I. apply In_singleton.
Qed.

Lemma der_list_conj_finite_context : forall l (Γ : Ensemble _),
  (forall B : _, (Γ B -> List.In B l) * (List.In B l -> Γ B)) ->
  wBIH_rules (Γ, list_conj l).
Proof.
induction l ; intros.
- simpl. apply wTop.
- simpl. destruct (In_dec l a).
  + assert (forall B : _, (Γ B -> List.In B l) * (List.In B l -> Γ B)).
     intros. split ; intro. apply H in H0. inversion H0. subst. auto. auto.
     apply H. apply in_cons ; auto. pose (IHl Γ H0).
     apply MP with (ps:=[(Γ, list_conj l → (a ∧ list_conj l));(Γ, list_conj l)]). 2: apply MPRule_I.
     intros. inversion H1. subst.
     apply MP with (ps:=[(Γ, (list_conj l → list_conj l) → (list_conj l → (a ∧ list_conj l)));(Γ, list_conj l → list_conj l)]). 2: apply MPRule_I.
     intros. inversion H2. subst.
     apply MP with (ps:=[(Γ, (list_conj l → a) → (list_conj l → list_conj l) → (list_conj l → (a ∧ list_conj l)));(Γ, list_conj l → a)]). 2: apply MPRule_I.
     intros. inversion H3. subst. apply Ax. apply AxRule_I. apply RA7_I. exists (list_conj l). exists a. exists (list_conj l). auto.
     inversion H4. 2: inversion H5. subst. apply MP with (ps:=[(Γ, a → list_conj l → a);(Γ, a)]).
     2: apply MPRule_I. intros. inversion H5. subst. apply wThm_irrel. inversion H6. subst. apply Id.
     apply IdRule_I. apply H. apply in_eq. inversion H7. inversion H3. subst. apply wimp_Id_gen. inversion H4.
     inversion H2 ; subst ; auto. inversion H3.
  + assert (J1: (forall B : _, ((fun x : _ => In _ Γ x /\ x <> a) B -> List.In B l) * (List.In B l -> (fun x : _ => In _ Γ x /\ x <> a) B))).
     intros. split ; intro. destruct H0. apply H in H0. inversion H0. subst. exfalso. apply H1 ; auto. auto.
     split. apply H. apply in_cons ; auto. intro. subst. auto.
     pose (IHl (fun x => In _ Γ x /\ x <> a) J1).
     apply MP with (ps:=[(Γ, list_conj l → (a ∧ list_conj l));(Γ, list_conj l)]). 2: apply MPRule_I.
     intros. inversion H0. subst.
     apply MP with (ps:=[(Γ, (list_conj l → list_conj l) → (list_conj l → (a ∧ list_conj l)));(Γ, list_conj l → list_conj l)]). 2: apply MPRule_I.
     intros. inversion H1. subst.
     apply MP with (ps:=[(Γ, (list_conj l → a) → (list_conj l → list_conj l) → (list_conj l → (a ∧ list_conj l)));(Γ, list_conj l → a)]). 2: apply MPRule_I.
     intros. inversion H2. subst. apply Ax. apply AxRule_I. apply RA7_I. exists (list_conj l). exists a. exists (list_conj l). auto.
     inversion H3. 2: inversion H4. subst. apply MP with (ps:=[(Γ, a → list_conj l → a);(Γ, a)]).
     2: apply MPRule_I. intros. inversion H4. subst. apply wThm_irrel. inversion H5. subst. apply Id.
     apply IdRule_I. apply H. apply in_eq. inversion H6. inversion H2. subst. apply wimp_Id_gen. inversion H3.
     inversion H1 ; subst ; auto. 2: inversion H2. apply wBIH_monot with (Γ1:=Γ) in w. apply w. simpl. intro. intros.
     inversion H2. auto.
Qed.

Lemma list_conj_finite_context : forall l (Γ : Ensemble _) A,
  (forall B : _, (Γ B -> List.In B l) * (List.In B l -> Γ B)) ->
  wBIH_rules (Singleton _ (list_conj l), A) ->
  wBIH_rules (Γ, A).
Proof.
intros.
assert (wBIH_rules (Singleton _ (list_conj l), list_conj l)). apply Id. apply IdRule_I. apply In_singleton.
assert (forall A : _, In _ (fst (Singleton _ (list_conj l), list_conj l)) A -> wBIH_rules (Γ, A)).
intros. simpl in H2. inversion H2. subst. apply der_list_conj_finite_context ; auto.
pose (wBIH_comp (Singleton _ (list_conj l), A) H0 Γ H2). simpl in w. auto.
Qed.

(* Dual MP *)

Theorem dual_MP : forall A B Δ,
  wpair_derrec (Singleton _ (Excl A B), Δ) ->
  wpair_derrec (Singleton _ B, Δ) ->
      wpair_derrec (Singleton _ A, Δ).
Proof.
intros. destruct H. destruct H0. destruct H. destruct H1. destruct H0. destruct H3. simpl in H1.
simpl in H2. simpl in H3. simpl in H4. unfold wpair_derrec. exists (x ++ remove_list x x0). repeat split.
apply add_remove_list_preserve_NoDup ; auto. intros. simpl. apply in_app_or in H5. destruct H5.
apply H1 ; auto. apply In_remove_list_In_list in H5. apply H3 ; auto. simpl.
assert (wBIH_rules (Singleton _ (Excl A B), list_disj (x ++ remove_list x x0))).
assert (Singleton _ (Excl A B) = Union _ (Empty_set _) (Singleton _ (Excl A B))).
apply Extensionality_Ensembles. split ; intro ; intro. apply Union_intror ; auto.
inversion H5. inversion H6. auto. rewrite H5. clear H5.
apply wBIH_Detachment_Theorem with (s:=(Empty_set _, Imp (Excl A B) (list_disj (x ++ remove_list x x0)))) ; auto.
apply der_list_disj_remove1. apply wBIH_Deduction_Theorem with (s:=( Union _ (Empty_set _) (Singleton _ (Excl A B)),list_disj x)) ; auto.
assert (Union _ (Empty_set _) (Singleton _ (Excl A B)) = Singleton _ (Excl A B)).
apply Extensionality_Ensembles. split ; intro ; intro. inversion H5. inversion H6. auto.
apply Union_intror ; auto. rewrite H5. clear H5. auto.
assert (wBIH_rules (Singleton _ B, list_disj (x ++ remove_list x x0))).
assert (Singleton _ B = Union _ (Empty_set _) (Singleton _ B)).
apply Extensionality_Ensembles. split ; intro ; intro. apply Union_intror ; auto.
inversion H6. inversion H7. auto. rewrite H6. clear H6.
apply wBIH_Detachment_Theorem with (s:=(Empty_set _, B → list_disj (x ++ remove_list x x0))) ; auto.
apply der_list_disj_remove2. apply wBIH_Deduction_Theorem with (s:=( Union _ (Empty_set _) (Singleton _ B),list_disj x0)) ; auto.
assert (Union _ (Empty_set _) (Singleton _ B) = Singleton _ B).
apply Extensionality_Ensembles. split ; intro ; intro. inversion H6. inversion H7. auto.
apply Union_intror ; auto. rewrite H6. clear H6. auto.
assert (Singleton _ A = Union _ (Empty_set _) (Singleton _ A)). apply Extensionality_Ensembles.
split ; intro ; intro. apply Union_intror ; auto. inversion H7. subst. inversion H8. subst. auto.
rewrite H7. clear H7.
apply wBIH_Detachment_Theorem with (s:=(Empty_set _, A → list_disj (x ++ remove_list x x0))) ; auto.
apply MP with (ps:=[(Empty_set _, ((B ∨ (Excl A B)) → list_disj (x ++ remove_list x x0)) → (A → list_disj (x ++ remove_list x x0)));
(Empty_set _, ((B ∨ (Excl A B)) → list_disj (x ++ remove_list x x0)))]). 2: apply MPRule_I.
intros. inversion H7 ; subst.
apply MP with (ps:=[(Empty_set _, (A → (B ∨ (Excl A B))) → ((B ∨ (Excl A B)) → list_disj (x ++ remove_list x x0)) → (A → list_disj (x ++ remove_list x x0)));
(Empty_set _, A → (B ∨ (Excl A B)))]). 2: apply MPRule_I.
intros. inversion H8 ; subst. apply Ax. apply AxRule_I. apply RA1_I. exists A. exists (B ∨ (Excl A B)).
exists (list_disj (x ++ remove_list x x0)). auto. inversion H9 ; subst. 2: inversion H10. apply Ax.
apply AxRule_I. apply RA11_I. exists A. exists B ; auto. inversion H8. subst. 2: inversion H9.
apply MP with (ps:=[(Empty_set _, ((Excl A B) → list_disj (x ++ remove_list x x0)) → ((B ∨ (Excl A B)) → list_disj (x ++ remove_list x x0)));
(Empty_set _, (Excl A B) → list_disj (x ++ remove_list x x0))]). 2: apply MPRule_I.
intros. inversion H9. subst.
apply MP with (ps:=[(Empty_set _, (B → list_disj (x ++ remove_list x x0)) → ((Excl A B) → list_disj (x ++ remove_list x x0)) → ((B ∨ (Excl A B)) → list_disj (x ++ remove_list x x0)));
(Empty_set _, B → list_disj (x ++ remove_list x x0))]). 2: apply MPRule_I.
intros. inversion H10. subst. apply Ax. apply AxRule_I. apply RA4_I. exists B. exists (Excl A B).
exists (list_disj (x ++ remove_list x x0)). auto. inversion H11 ; subst. 2: inversion H12.
apply wBIH_Deduction_Theorem with (s:=(Union _ (Empty_set _) (Singleton _ B), list_disj (x ++ remove_list x x0))) ; auto.
assert (Union _ (Empty_set _) (Singleton _ B) = Singleton _ B).
apply Extensionality_Ensembles. split ; intro ; intro. inversion H12. inversion H13. auto.
apply Union_intror ; auto. rewrite H12 ; auto. inversion H10. 2: inversion H11. subst.
apply wBIH_Deduction_Theorem with (s:=(Union _ (Empty_set _) (Singleton _ (Excl A B)), list_disj (x ++ remove_list x x0))) ; auto.
assert (Union _ (Empty_set _) (Singleton _ (Excl A B)) = Singleton _ (Excl A B)).
apply Extensionality_Ensembles. split ; intro ; intro. inversion H11. inversion H12. auto.
apply Union_intror ; auto. rewrite H11 ; auto.
Qed.


Module Type RED_STRATEGY_LANG.

  Parameters
  (term          : Set)
  (elem_context  : Set)
  (ckind         : Set)
  (ckind_trans   : ckind -> elem_context -> ckind)
  (init_ckind    : ckind)
  (dead_ckind    : ckind -> Prop)
  (elem_plug     : term -> elem_context -> term)
  (value         : ckind -> Set)
  (redex         : ckind -> Set)
  (value_to_term : forall {k}, value k -> term)
  (redex_to_term : forall {k}, redex k -> term).

  Infix "+>"           := ckind_trans (at level 50, left associativity).
  Notation "ec :[ t ]" := (elem_plug t ec) (at level 0).
  Coercion  value_to_term : value >-> term.
  Coercion  redex_to_term : redex >-> term.

  Inductive context (k1 : ckind) : ckind -> Set :=
  | empty : context k1 k1
  | ccons : forall (ec : elem_context) {k2}, context k1 k2 -> context k1 (k2+>ec).
  Arguments empty {k1}. Arguments ccons {k1} _ {k2} _.
  Notation "[.]"      := empty.
  Notation "[.]( k )" := (@empty k).
  Infix    "=:"       := ccons (at level 60, right associativity).

  Fixpoint compose {k1 k2} (c0 : context k1 k2)
                      {k3} (c1 : context k3 k1) : context k3 k2 :=
      match c0 in context _ k2' return context k3 k2' with
      | [.]     => c1
      | ec=:c0' => ec =: compose c0' c1
      end.
  Infix "~+" := compose (at level 60, right associativity).

  Fixpoint plug (t : term) {k1 k2} (c : context k1 k2) : term :=
      match c with
      | [.]    => t
      | ec=:c' => plug ec:[t] c'
      end.
  Notation "c [ t ]" := (plug t c) (at level 0).

  Definition immediate_ec ec t := exists t', ec:[t'] = t.

  Inductive decomp k : Set :=
  | d_red : forall {k'}, redex k' -> context k k' -> decomp k
  | d_val : value k -> decomp k.
  Arguments d_val {k} _. Arguments d_red {k} {k'} _ _.

  Coercion decomp_to_term {k} (d : decomp k) :=
      match d with
      | d_val v   => value_to_term v
      | d_red r c => c[r]
      end.

  Definition dec (t : term) k (d : decomp k) : Prop :=
      ~dead_ckind k /\ t = d.

  Axioms
  (init_ckind_alive :
       ~dead_ckind init_ckind)

  (death_propagation :                                                       forall k ec,
       dead_ckind k -> dead_ckind (k+>ec))

  (proper_death :                                                               forall k,
       dead_ckind k -> ~ exists (r : redex k), True)

  (value_to_term_injective :                                 forall {k} (v v' : value k),
       value_to_term v = value_to_term v' -> v = v')

  (redex_to_term_injective :                                 forall {k} (r r' : redex k),
       redex_to_term r = redex_to_term r' -> r = r')

  (elem_plug_injective1 :                                                forall ec t0 t1,
       ec:[t0] = ec:[t1] -> t0 = t1)

  (value_trivial1 :                                                      forall {k} ec t,
       forall v : value k, ~dead_ckind (k+>ec) -> ec:[t] = v ->
           exists (v' : value (k+>ec)), t = v')

  (value_redex :                                                             forall {k},
       forall (v : value k) (r : redex k), value_to_term v <> redex_to_term r).

End RED_STRATEGY_LANG.

Module Type RED_STRATEGY_STEP (R : RED_STRATEGY_LANG).

  Import R.

  Inductive interm_dec k : Set :=
  | in_red  : redex k -> interm_dec k
  | in_term : term -> elem_context -> interm_dec k
  | in_val  : value k -> interm_dec k
  | in_dead : interm_dec k.
  Arguments in_red {k} _.    Arguments in_val {k} _.
  Arguments in_term {k} _ _. Arguments in_dead {k}.

  (* dec_term t k       - one step of decomposition of t considered in the hole of
                          the kind k if we have no information about subterms of t.
                          Proper domain:  term * { k : ckind | k is not dead }
     dec_context ec k v - one step of decomposition of a term ec[v] considered in
                          the hole of the kind k after finding out that v is a value.
                          Proper domain:  elem_context * { (k, v) | k+>ec is not dead
                                                           and v : value (k+>ec)      }
  *)
  Parameters
  (dec_term    : term -> forall k, interm_dec k)
  (dec_context : forall ec k, value (k+>ec) -> interm_dec k).

  Axioms
  (dec_term_correct :
       forall t k, match dec_term t k with
       | in_red r      => t = r
       | in_val v      => t = v
       | in_term t' ec => t = ec:[t']
       | in_dead       => dead_ckind k
       end)

  (dec_term_from_dead :                                                       forall t k,
      dead_ckind k -> dec_term t k = in_dead)

  (dec_context_correct :                                                   forall ec k v,
      match dec_context ec k v with
      | in_red r      => ec:[v] = r
      | in_val v'     => ec:[v] = v'
      | in_term t ec' => ec:[v] = ec':[t]
      | in_dead       => dead_ckind (k+>ec)
      end)

  (dec_context_from_dead :                               forall ec k (v : value (k+>ec)),
      dead_ckind (k+>ec) -> dec_context ec k v = in_dead)

  (dec_term_next_alive :                                               forall t k t0 ec0,
      dec_term t k = in_term t0 ec0 -> ~dead_ckind (k+>ec0))

  (dec_context_next_alive :                                         forall ec k v t0 ec0,
      dec_context ec k v = in_term t0 ec0 -> ~ dead_ckind (k+>ec0)).

End RED_STRATEGY_STEP.

Module Type RED_STRATEGY (R : RED_STRATEGY_LANG).

  Import R.

  Include RED_STRATEGY_STEP R.

  Parameter search_order : ckind -> term -> elem_context -> elem_context -> Prop.
  Notation "k , t |~  ec1 << ec2 " := (search_order k t ec1 ec2)
               (at level 70, t, ec1, ec2 at level 50, no associativity).

  Axiom dec_term_term_top :
      forall t k {t' ec}, dec_term t k = in_term t' ec ->
          forall ec',  ~ k, t |~ ec << ec'.

  Axiom dec_context_red_bot :
      forall k ec v {r : redex k}, dec_context ec k v = in_red r ->
          forall ec',  ~ k, ec:[v] |~ ec' << ec.

  Axiom dec_context_val_bot :
      forall k ec v {v' : value k}, dec_context ec k v = in_val v' ->
          forall ec',  ~ k, ec:[v] |~ ec' << ec.

  Axiom dec_context_term_next :
      forall ec0 k v {t ec1}, dec_context ec0 k v = in_term t ec1 ->
      (*1*) k, ec0:[v] |~ ec1 << ec0 /\
      (*2*) forall ec,  k, ec0:[v] |~ ec << ec0  ->  ~ k, ec0:[v] |~ ec1 << ec.

  Axiom elem_context_det :
      forall t ec {t'}, t = ec:[t'] ->
          forall k ec',  k, t |~ ec' << ec ->
              exists (v : value (k+>ec)), t' = v.

End RED_STRATEGY.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <aciclo@gmail.com>                                        *)
(*                                        Computer Science Department, USTC   *)
(*                                                                            *)
(*           Hui Zhang <sa512073@mail.ustc.edu.cn>                            *)
(*                                     School of Software Engineering, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Export bnat.
Require Import LibEx.
Require Import ListEx.
Require Import Monad.
Require Import Data.

Require Import Params.

(* NAND hardware interface *)

(* Definition oob := list int. *)

Definition page_off := nat.

Definition block_no := nat.

Definition page_off_of_nat (n: nat) : page_off := n.

Definition page_no := prod block_no page_off.

Inductive page_status : Set :=
  | ps_free
  | ps_programmed.

Inductive block_status : Set :=
  | bs_free
  | bs_programmed.

Record page : Set :=
  mkpage {
      page_data : data;
      page_oob : data;
      page_state : page_status
      (* data_size: length (page_data) = PAGE_DATA_SIZE; *)
      (* oob_size: length (page_data) = PAGE_SPAREAREA_SIZE *)
    }.

Record block : Set :=
  mkblock {
      block_pages : list page;
      next_page : page_off;
      block_erase_count: nat;
      block_state : block_status
      (* pages_size: length block_pages = PAGES_PER_BLOCK *)
    }.

Record chip : Set :=
  mkchip {
      chip_blocks: list block
      (* blocks_size : length chip_blocks = BLOCKS *)
    }.

(********* Initialization of the Nand Chip ****************)

Definition init_page_data : data :=
  list_repeat_list PAGE_DATA_SIZE c_ff.

Definition init_page_oob : data :=
  list_repeat_list PAGE_SPARE_AREA_SIZE c_ff.

Definition init_page : page :=
  mkpage init_page_data init_page_oob ps_free.

Definition init_block : block :=
  mkblock (list_repeat_list PAGES_PER_BLOCK init_page) 0 0 bs_free.

Definition erased_block (ec: nat): block :=
  mkblock (list_repeat_list PAGES_PER_BLOCK init_page) 0 (S ec) bs_free.

Definition bvalid_block_no (pbn: block_no) : bool :=
  (blt_nat pbn BLOCKS).

Definition bvalid_page_off (off: page_off) : bool :=
  (blt_nat off PAGES_PER_BLOCK).

(********* Nand chip Operations ***************)
Definition nand_init : chip :=
  mkchip (list_repeat_list BLOCKS init_block).

(* written by zhanghui, generate the content of 'oob' according to the
data stored in this page. *)
(* TEMP: now just return a list of null *)
Definition make_oob (d : data) : data :=
  list_repeat_list PAGE_SPARE_AREA_SIZE c_null.

Definition chip_get_block (c: chip) (pbn: block_no): option block :=
  list_get (chip_blocks c) pbn.

Definition chip_set_block (c: chip) (pbn: block_no) (b: block) : option chip :=
  test bvalid_block_no pbn;
  do nbl <-- list_set (chip_blocks c) pbn b;
  ret (mkchip nbl).

Definition block_get_page (b: block) (off: page_off) : option page :=
  test (bvalid_page_off off);
  do p <-- (list_get (block_pages b) off);
  ret p.

Definition block_set_page (b: block) (off: page_off) (p: page) : option block :=
  test bvalid_page_off off;
  do npl <-- list_set (block_pages b) off p;
  ret (mkblock npl (next_page b) (block_erase_count b) bs_programmed).

Definition block_set_next_page (b: block) (off: page_off) : option block :=
  ret (mkblock (block_pages b) (off) (block_erase_count b) (block_state b)).

Definition chip_get_page (c: chip) (bln: block_no) (poff: page_off) : option page :=
  match chip_get_block c bln with
    | None => None
    | Some b =>
      block_get_page b poff
  end.

Definition page_get_data (p: page) : option data :=
  match page_state p with
    | ps_free => None (* This is an empty page, no data. *)
    | ps_programmed => Some (page_data p)
  end.

Definition check_page_state_is_free (ps : page_status) : bool :=
  match ps with
    | ps_free => true
    | _ => false
  end.

(********* Nand chip Operations ***************)
Definition nand_read_page (c: chip) (pbn: block_no) (poff: page_off) : option (prod data data) :=
  test (bvalid_block_no pbn);
  do b <-- chip_get_block c pbn;
  test (bvalid_page_off poff);
  do p <-- block_get_page b poff;
  ret (page_data p, page_oob p).

Definition nand_write_page (c: chip) (pbn: block_no) (off: page_off) (d: data) (o: data): option chip :=
  test (bvalid_block_no pbn);
  do b <-- chip_get_block c pbn;
  test (bvalid_page_off off);
  test (ble_nat (next_page b) off);
  do p <-- block_get_page b off;
  test (check_page_state_is_free (page_state p));
  do b' <-- block_set_page b off (mkpage d o ps_programmed);
  do b'' <-- block_set_next_page b' (S off);
  do c' <-- chip_set_block c pbn b'';
  ret c'.

Definition nand_erase_block (c: chip) (pbn: block_no) : option chip :=
  test (bvalid_block_no pbn);
  do b <-- chip_get_block c pbn;
  let b' := erased_block (block_erase_count b) in
  do c' <-- chip_set_block c pbn b';
  ret c'.