Require Import QArith List Omega ZArith pol Zwf Recdef.

(* After a use of simpl, products of positive integers are replaced by
 products of positive numbers encapsulated in a Zpos constructor.  This
 precludes uses of some theorems.  We can undo this using the following
 tactic. *)

Ltac expand_Zpos_mult :=
  repeat match goal with |- context [Zpos(?a * ?b)] =>
     change (Zpos(a*b)) with ((Zpos a)*(Zpos b))%Z
  end.

(* We want to prove a simple and contructive approximation of the
 middle value theorem: if a polynomial is negative in a and positive in b,
 and a < b, then for any positive epsilon, there exists c and d, so that
 a <= c < d <= b, the polynomial is negative in c and positive and d,
 and the variation between c and d is less than epsilon.  To prove this,
 we use a second polynomial, obtained by taking the the absolute value
 of each coefficient.

  We will use absolute values on rational numbers, the
  absolute value is defined using a max function, called Qmax.

  We first need a host of lemmas on the type of rational numbers, which
  is rather bare. *)

Lemma Qmult_lt_0_compat :
  forall x y, 0 < x -> 0 < y -> 0 < x * y.
intros x y Hx Hy.
assert (H0: 0 == 0 * y) by ring; rewrite H0.
apply Qmult_lt_compat_r; auto.
Qed.

Definition Qmax (x y:Q) := if Qlt_le_dec x y then y else x.

Lemma Qmax_le_l : forall x y, x <= Qmax x y.
intros x y; unfold Qmax; case (Qlt_le_dec x y); intro; apply Qle_refl ||
  apply Qlt_le_weak; assumption.
Qed.

Lemma Qmax_le_r : forall x y, y <= Qmax x y.
intros x y; unfold Qmax; case (Qlt_le_dec x y); intro; apply Qle_refl || auto.
Qed.

Lemma neg_opp_pos : forall x, x < 0 -> 0 < - x.
intros x; unfold Qlt, Qopp; simpl; intro; omega.
Qed.

Definition Qabs (x:Q) := Qmax x (-x).

Lemma Qabs_le : forall x, x <= Qabs x.
intros x; unfold Qabs, Qmax; case (Qlt_le_dec x (-x)); intro;
 apply Qle_refl || apply Qlt_le_weak; auto.
Qed.

(* This is a basic decomposition lemma, already present for most other
 numeric types. *)

Lemma Qplus_le_lt_compat :
  forall a b c d, a <= b -> c < d -> a + c < b + d.
intros [a1 a2] [b1 b2] [c1 c2] [d1 d2] H1 H2.
  apply Qlt_le_trans with ((a1#a2) + (d1#d2)).
unfold Qle, Qlt, Qplus in *; simpl in *.
repeat rewrite Zmult_plus_distr_l.
replace (a1* 'd2 * '(a2 * c2))%Z with (a1 * 'c2 * '(a2*d2))%Z.
apply Zplus_lt_compat_l.
replace (c1*'a2*'(a2*d2))%Z with  (('a2*'a2) *(c1*'d2))%Z.
replace (d1*'a2*'(a2*c2))%Z with (('a2*'a2)*(d1*'c2))%Z.
apply Zmult_lt_compat_l; auto.
compute; apply refl_equal.
replace ('(a2*c2))%Z with ('a2 *'c2)%Z by auto; ring.
replace ('(a2*d2))%Z with ('a2 *'d2)%Z by auto; ring.
replace ('(a2*d2))%Z with ('a2 *'d2)%Z by auto.
replace ('(a2*c2))%Z with ('a2 *'c2)%Z by auto; ring.
unfold Qlt, Qle, Qplus in *; simpl in *.
repeat rewrite Zmult_plus_distr_l.
replace (d1* 'b2 * '(a2 * d2))%Z with (d1 * 'a2 * '(b2*d2))%Z.
apply Zplus_le_compat_r.
replace (a1*'d2*'(b2*d2))%Z with  (('d2*'d2) *(a1*'b2))%Z.
replace (b1*'d2*'(a2*d2))%Z with (('d2*'d2)*(b1*'a2))%Z.
apply Zmult_le_compat_l; auto.
compute; intros; discriminate.
replace ('(a2*d2))%Z with ('a2 *'d2)%Z by auto; ring.
replace ('(b2*d2))%Z with ('b2 *'d2)%Z by auto; ring.
replace ('(b2*d2))%Z with ('b2 *'d2)%Z by auto.
replace ('(a2*d2))%Z with ('a2 *'d2)%Z by auto; ring.
Qed.

Lemma lt_opp_pos : forall x, -x < x -> 0 < x.
intros x ltx;
assert (half_pos:0 < /(2#1)) by (unfold Qlt; simpl; omega).
setoid_replace x with ((x+x)*/(2#1)) by field.
setoid_replace 0 with ((x+-x)*/(2#1)) by ring.
apply Qmult_lt_compat_r; auto.
apply Qplus_le_lt_compat; try apply Qle_refl; auto.
Qed.

Lemma le_opp_pos : forall x, -x <= x -> 0 <= x.
intros x lex; assert (H02 : 0 == 0*/(2#1)) by ring;
assert (half_pos:0 <= /(2#1)) by (unfold Qle; simpl; omega).
rewrite H02.
setoid_replace x with ((x+x)*/(2#1)) by field.
apply Qmult_le_compat_r; auto.
setoid_replace 0 with (x+-x) by ring.
apply Qplus_le_compat; try apply Qle_refl; auto.
Qed.

Lemma Qabs_le_0 : forall x, 0 <= Qabs x.
intros x; unfold Qabs, Qmax.
case (Qlt_le_dec x (-x));[intros xneg | intros xpos].
apply Qlt_le_weak; apply lt_opp_pos; rewrite Qopp_opp; auto.
apply le_opp_pos; auto.
Qed.

Lemma Qopp_lt_compat : forall x y, x < y -> -y < -x.
intros x y xy; rewrite <- (Qplus_0_r (-x));
setoid_replace (-y) with (-x + (-y+x)) by ring.
setoid_replace 0 with (-y + y) by ring.
do 2 (apply Qplus_le_lt_compat; try apply Qle_refl); auto.
Qed.

Lemma Qopp_lt_lr : forall x y, x < - y -> y < - x.
intros x y xy; setoid_replace y with (- - y) by ring.
apply Qopp_lt_compat; assumption.
Qed.

Lemma Qopp_lt_rl : forall x y, -x < y -> - y < x.
intros x y xy; setoid_replace x with (- - x) by ring.
apply Qopp_lt_compat; assumption.
Qed.

Lemma Qopp_le_lr : forall x y, x <= - y -> y <= - x.
intros x y xy; setoid_replace y with (- - y) by ring.
apply Qopp_le_compat; assumption.
Qed.

Lemma Qopp_le_rl : forall x y, -x <= y -> - y <= x.
intros x y xy; setoid_replace x with (- - x) by ring.
apply Qopp_le_compat; assumption.
Qed.

Lemma pos_Qabs : forall x, 0 <= x -> Qabs x = x.
intros x xpos; unfold Qabs, Qmax; case (Qlt_le_dec x (-x)); auto.
intros xmx; assert (abs: 0 < -x)
  by (apply lt_opp_pos; rewrite Qopp_opp; assumption).
apply Qopp_lt_compat in abs; change (-0) with 0 in abs;
 rewrite Qopp_opp in abs; apply Qlt_not_le in abs; contradiction.
Qed.

Lemma neg_Qabs : forall x, x <= 0 -> Qabs x = -x.
intros x xneg; unfold Qabs, Qmax; case (Qlt_le_dec x (-x)); auto.
intros mxx; unfold Qopp.
assert (Hx0 : x==0) by (apply Qle_antisym; auto; apply le_opp_pos; auto).
destruct x; unfold Qeq in Hx0; simpl in Hx0 |- *; rewrite Zmult_1_r in Hx0.
rewrite Hx0; simpl; auto.
Qed.

Lemma opp_Qabs_le :  forall x, -x <= Qabs x.
intros x; unfold Qabs, Qmax; case (Qlt_le_dec x (-x)); intro; auto;
 apply Qle_refl.
Qed.

Lemma Qabs_mult : forall x y, Qabs (x * y) == Qabs x * Qabs y.
intros x y; unfold Qabs, Qmax.
destruct (Qlt_le_dec x (- x)) as [hx | hx];
destruct (Qlt_le_dec y (- y)) as [hy | hy];
destruct (Qlt_le_dec (x * y) (-(x*y))) as [hp | hp]; try ring.
assert (nx:0 < -x) by (apply lt_opp_pos; rewrite Qopp_opp; auto).
assert (ny:0 < -y) by (apply lt_opp_pos; rewrite Qopp_opp; auto).
case Qlt_not_le with (1:=hp).
setoid_replace (-(x*y)) with (x*(-y)) by ring.
setoid_replace (x*y) with (-x*(-y)) by ring.
apply Qmult_le_compat_r; apply Qlt_le_weak; auto.
assert (nx:0 < -x) by (apply lt_opp_pos; rewrite Qopp_opp; auto).
assert (py:0 <= y) by (apply le_opp_pos; auto).
case (Qle_lt_or_eq _ _ py); intros hy'.
case Qle_not_lt with (1:=hp).
setoid_replace (-(x*y)) with (-x*y) by ring.
apply Qmult_lt_compat_r; auto.
rewrite <- hy'; ring.
assert (px:0<=x) by (apply le_opp_pos; auto).
case (Qle_lt_or_eq _ _ px); intros hx'.
case Qle_not_lt with (1:=hp).
setoid_replace (-(x*y)) with (x*(-y)) by ring.
repeat rewrite (Qmult_comm x); apply Qmult_lt_compat_r; auto.
rewrite <- hx'; ring.
case (Qlt_not_le _ _ hp).
setoid_replace (-(x*y)) with (-x*y) by ring.
apply Qmult_le_compat_r; auto; apply le_opp_pos; auto.
Qed.

Lemma Qabs_plus : forall x y, Qabs (x + y) <= Qabs x + Qabs y.
intros x y; unfold Qabs, Qmax; case (Qlt_le_dec x (-x));
 case (Qlt_le_dec y (-y)); case (Qlt_le_dec (x+y) (-(x+y)));
 try (setoid_replace (-(x+y)) with (-x+ -y) by ring);
 try (intros; apply Qle_refl); intros xy xx yy.

case (Qle_not_lt _ _ xy); apply Qplus_le_lt_compat; auto;
 apply Qlt_le_weak; auto.
repeat rewrite (Qplus_comm x); apply Qplus_le_compat; auto; apply Qle_refl.
repeat rewrite <- (Qplus_comm y); apply Qplus_le_compat;
 try (apply Qlt_le_weak; solve[auto]); apply Qle_refl.
apply Qplus_le_compat; auto; apply Qle_refl.
apply Qplus_le_compat; try apply Qle_refl; apply Qlt_le_weak; auto.
apply Qplus_le_compat; auto.
Qed.

Lemma Qabs_interval : forall x y z, x < y -> y < z ->
  Qabs y < Qmax (Qabs x) (Qabs z).
intros x y z xy yz; unfold Qabs at 1, Qmax at 1; case (Qlt_le_dec y (-y)).
intros yneg; apply Qlt_le_trans with (Qabs x); try apply Qmax_le_l.
assert (yneg': 0 < -y) by (apply lt_opp_pos; rewrite Qopp_opp; assumption).
assert (yneg'' : y < 0).
assert (H0 : 0 == y + -y) by ring; rewrite H0; clear H0.
set (u:= y + -y);
 assert (H0 : y == y + 0) by ring; rewrite H0; clear H0; unfold u.
apply Qplus_le_lt_compat; auto; apply Qle_refl.
assert (xneg: x < 0) by (apply Qlt_trans with y; auto).
assert (xneg' : x < -x).
apply Qlt_trans with 0; auto; apply neg_opp_pos; auto.
unfold Qabs, Qmax; case (Qlt_le_dec x (-x)).
intros _; setoid_replace (-x) with ((-y + -x)+y) by ring.
set (u:= (-y+-x)+y); setoid_replace (-y) with ((-y + -x)+x) by ring;
 unfold u; clear u.
apply Qplus_le_lt_compat; try apply Qle_refl; auto.
intro; case (Qlt_not_le _ _ xneg'); auto.
intros ypos; apply le_opp_pos in ypos;
 assert (zpos : 0 < z) by (apply Qle_lt_trans with y; auto).
apply Qlt_le_trans with (Qabs z); try apply Qmax_le_r.
rewrite pos_Qabs; auto; apply Qlt_le_weak; auto.
Qed.

Lemma inv_pos : forall x, 0 < x -> 0 < /x.
intros [ [| x| x] y]; unfold Qlt, Qinv; simpl; compute; auto.
Qed.

Lemma Qabs_non_pos : forall x, Qabs x <= 0 -> x == 0.
intros x; unfold Qabs, Qmax; case (Qlt_le_dec x (-x)).
intros l1 l2; apply Qle_antisym; rewrite <- (Qopp_opp x);
rewrite <- (Qopp_opp 0); apply Qopp_le_compat; auto.
apply le_opp_pos.
rewrite Qopp_opp; apply Qlt_le_weak; auto.
intros l1 l2; apply Qle_antisym; auto; apply le_opp_pos; auto.
Qed.

Lemma Qmult_le_reg_r : forall a b, 0 < b -> 0 <= a * b -> 0 <= a.
intros a b pb ab; assert (~ b==0)
  by (intros q; rewrite q in pb; discriminate pb).
rewrite <- (Qdiv_mult_l a b); auto.
assert (d0 : 0 == 0 * /b) by ring; rewrite d0; clear d0.
unfold Qdiv; apply Qmult_le_compat_r; auto;
 apply Qlt_le_weak; apply inv_pos; auto.
Qed.

Lemma Qmult_le_reg_l : forall a b, 0 < b -> 0 <= b * a -> 0 <= a.
intros a b pb ab; apply (Qmult_le_reg_r a b); auto; rewrite Qmult_comm; auto.
Qed.

(* Polynomial are only represented by the list of their coefficients.
  To any polynomial, we associate the absolute polynomial, whose
  coefficients are the absolute values of the initial coefficients. *)

Fixpoint Qabs_pol (l:list Q) :list Q :=
 match l with nil => nil | a::tl => Qabs a::Qabs_pol tl end.

(* The value of the absolute polynomial is always larger than the value
 of the initial polynomial. *)

Hint Resolve Qabs_le Qabs_le_0 opp_Qabs_le Qle_refl Qlt_le_weak Qinv_lt_0_compat.

Lemma Qabs_pol_bound :
  forall l x, Qabs (eval_pol l x) <= eval_pol (Qabs_pol l) (Qabs x).
induction l; intros x; simpl; unfold Qabs, Qmax;
  try solve [case (Qlt_le_dec 0 (-0)); simpl; intros; apply Qle_refl].
destruct (Qlt_le_dec (a + x * eval_pol l x) (-(a+x*eval_pol l x))) as
 [test|test]; (case_eq (Qlt_le_dec a (-a)); [intros aneg ta | intros apos ta]);
(case_eq (Qlt_le_dec x (-x)); [intros xneg tx | intros xpos tx]).
rewrite Qopp_plus; apply Qplus_le_compat; try apply Qle_refl.
setoid_replace (-(x*eval_pol l x)) with (-x*eval_pol l x) by ring.
repeat rewrite (Qmult_comm (-x));apply Qmult_le_compat_r.
replace (-x) with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto).
apply Qle_trans with (Qabs (eval_pol l x)); auto.
replace (-x) with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); auto.
rewrite Qopp_plus; apply Qplus_le_compat; try apply Qle_refl.
setoid_replace (-(x*eval_pol l x)) with (x*-eval_pol l x) by ring.
repeat rewrite (Qmult_comm x);apply Qmult_le_compat_r.
set (u:=-eval_pol l x);
  replace x with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); unfold u.
apply Qle_trans with (Qabs (eval_pol l x)); auto.
replace x with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); auto.
rewrite Qopp_plus; apply Qplus_le_compat; auto.
setoid_replace (-(x*eval_pol l x)) with (-x*eval_pol l x) by ring.
repeat rewrite (Qmult_comm (-x));apply Qmult_le_compat_r.
replace (-x) with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto).
apply Qle_trans with (Qabs (eval_pol l x)); auto.
replace (-x) with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); auto.
rewrite Qopp_plus; apply Qplus_le_compat; auto.
setoid_replace (-(x*eval_pol l x)) with (x*-eval_pol l x) by ring.
repeat rewrite (Qmult_comm x);apply Qmult_le_compat_r.
set (u:=-eval_pol l x);
  replace x with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); unfold u.
apply Qle_trans with (Qabs (eval_pol l x)); auto.
replace x with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); auto.
apply Qplus_le_compat; try (apply Qlt_le_weak; assumption).
setoid_replace (x*eval_pol l x) with (-x*-eval_pol l x) by ring.
repeat rewrite (Qmult_comm (-x));apply Qmult_le_compat_r.
replace (-x) with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto).
apply Qle_trans with (Qabs (eval_pol l x)); auto.
replace (-x) with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); auto.
apply Qplus_le_compat; try (apply Qlt_le_weak; assumption).
repeat rewrite (Qmult_comm x);apply Qmult_le_compat_r.
set (u:=eval_pol l x);
  replace x with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); unfold u.
apply Qle_trans with (Qabs (eval_pol l x)); auto.
replace x with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto);auto.
apply Qplus_le_compat; try apply Qle_refl.
setoid_replace (x*eval_pol l x) with (-x*-eval_pol l x) by ring.
repeat rewrite (Qmult_comm (-x));apply Qmult_le_compat_r.
replace (-x) with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto).
apply Qle_trans with (Qabs (eval_pol l x)); auto.
replace (-x) with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); auto.
apply Qplus_le_compat; try apply Qle_refl.
repeat rewrite (Qmult_comm x);apply Qmult_le_compat_r.
set (u:=eval_pol l x);
  replace x with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); unfold u.
apply Qle_trans with (Qabs (eval_pol l x)); auto.
replace x with (Qabs x) by (unfold Qabs, Qmax; rewrite tx; auto); auto.
Qed.

Lemma Qabs_pol_pos :
  forall l x, 0 <= x -> 0 <= eval_pol (Qabs_pol l) x.
induction l; intros x px; simpl;
  [apply Qle_refl | apply Qle_trans with (0+0*x)].
ring_simplify; apply Qle_refl.
apply Qplus_le_compat; [apply Qabs_le_0 | rewrite (Qmult_comm x)].
apply Qmult_le_compat_r; auto.
Qed.

Lemma Qabs_pol_increase :
  forall l x y, 0 <= x -> x <= y ->
    eval_pol (Qabs_pol l) x <= eval_pol (Qabs_pol l) y.
induction l; intros x y px xy; simpl.
apply Qle_refl.
apply Qplus_le_compat;
  [apply Qle_refl | apply Qle_trans with (x*eval_pol (Qabs_pol l) y)].
repeat rewrite (Qmult_comm x); apply Qmult_le_compat_r; auto.
apply Qmult_le_compat_r; auto.
apply Qabs_pol_pos; apply Qle_trans with x; auto.
Qed.

(* A polynomial that has distinct values cannot be the null
 polynomial. *)

Lemma cm1 :
  forall l x y, eval_pol l x < eval_pol l y  -> exists a, l = a::(tail l).
intros l; case l.
simpl;intros x y abs; case (Qlt_not_le _ _ abs); apply Qle_refl.
intros a l' x y _; exists a; auto.
Qed.

(* To describe polynomial addition, multiplication by a scalar, and
  multiplication, we simply specify these operations so that their
  interpretation through polynomial evaluation returns the corresponding
  scalar operation. *)

Definition add_pol :
  forall l1 l2, {l' | forall x, eval_pol l1 x + eval_pol l2 x ==
  eval_pol l' x}.
induction l1 as [ | a l1 IHl1]; destruct l2 as [ | b l2].
exists (@nil Q); simpl; intros; ring.
exists (b::l2); simpl; intros; ring.
exists (a::l1); simpl; intros; ring.
destruct (IHl1 l2) as [l' q].
exists ((a+b)::l'); simpl; intros; rewrite <- q; ring.
Defined.

Definition s_mult_pol :
  forall a l, {l' | forall x, a * eval_pol l x == eval_pol l' x}.
intros a; induction l as [ | b l IHl]; simpl.
exists (@nil Q); simpl; intros; ring.
destruct IHl as [l' q]; exists ((a*b)::l'); simpl; intros; rewrite <- q; ring.
Defined.

Lemma mult_pol :
  forall l1 l2, {l' | forall x, eval_pol l1 x * eval_pol l2 x ==
   eval_pol l' x}.
induction l1 as [ | a l1 IHl1].
exists (@nil Q); simpl; intros; ring.
simpl.
intros l2; destruct (s_mult_pol a l2) as [l2a q].
destruct (IHl1 (0::l2)) as [l1l2x q1].
destruct (add_pol l1l2x l2a) as [l' q2].
exists l'; simpl; intros.
rewrite <- q2; rewrite <- q1; rewrite <- q; simpl; ring.
Qed.

Lemma translate_pol :
  forall l a, exists l', forall x, eval_pol l x == eval_pol l' (x - a).
induction l as [ | b l IHl]; intros a; simpl.
exists (@nil Q); simpl; intros; ring.
destruct (IHl a) as [l' q].
destruct (mult_pol (a::1::nil) l') as [l2 q2].
destruct (add_pol (b::nil) l2) as [l3 q3].
exists l3; intros x; rewrite <- q3; simpl;
   rewrite <- q2; rewrite q; simpl; ring.
Qed.

Add Morphism Qabs with signature Qeq ==> Qeq as Qabs_mor.
intros x1 x2 x1x2; unfold Qabs, Qmax;
  destruct (Qlt_le_dec x1 (-x1)) as [hx1 | hx1];
  destruct (Qlt_le_dec x2 (-x2)) as [hx2 | hx2];
  rewrite x1x2 in hx1 |- *; intros; try apply Qeq_refl.
case Qlt_not_le with (1:= hx1); auto.
case Qlt_not_le with (1:= hx2); auto.
Qed.

Add Morphism eval_pol with signature @eq (list Q) ==> Qeq ==> Qeq as eval_pol_mor.
intros l x y; induction l.
simpl; intros; apply Qeq_refl.
simpl; intros Hxy; rewrite IHl; auto; rewrite Hxy; apply Qeq_refl.
Qed.

Lemma cm2 :
  forall l b, { c |
  forall x, 0 <= x -> x <= b -> Qabs (eval_pol l x - eval_pol l 0) <= c * x}.
intros l b.
destruct l as [ | a l].
exists 0; simpl; intros; ring_simplify; apply Qle_refl.
simpl; exists (eval_pol (Qabs_pol l) b); intros x px xb; simpl.
match goal with |- Qabs(?v) <= _ =>
  assert (q: v == x*eval_pol l x) by ring; rewrite q
end.
rewrite Qabs_mult; rewrite (pos_Qabs x); auto; rewrite (Qmult_comm x).
apply Qmult_le_compat_r; auto.
apply Qle_trans with (2 := Qabs_pol_increase l x b px xb).
pattern x at 2; replace x with (Qabs x); [apply Qabs_pol_bound | idtac].
apply pos_Qabs; auto.
Defined.

Lemma QZ_bound : forall x:Q, 0 <= x -> {n | x <= n#1}.
intros [n d]; exists(Zdiv n (Zpos d)+1)%Z.
assert (dpos : (('d) > 0)%Z) by apply (refl_equal Gt).
unfold Qle; simpl; rewrite Zmult_1_r; rewrite Zmult_plus_distr_l.
pattern n at 1; rewrite (Z_div_mod_eq n ('d)); auto.
rewrite (Zmult_comm ('d)); apply Zplus_le_compat; auto with zarith.
rewrite Zmult_1_l; destruct (Z_mod_lt n ('d)) as [_ H2]; auto;
apply Zlt_le_weak; apply H2.
Defined.

Lemma Qdiv_lt_0_compat : forall x y, 0 < x -> 0 < y -> 0 < x / y.
intros x [[ | p | p] d] Hx Hy; unfold Qdiv, Qinv; simpl.
unfold Qlt in Hy; simpl in Hy; elimtype False; omega.
rewrite Qmult_comm;
assert (H0 : 0 == 0 * x) by ring; rewrite H0.
apply Qmult_lt_compat_r; auto.
unfold Qlt in Hy; simpl in Hy; discriminate Hy.
Qed.

Lemma cm3 :
  forall b, 0 < b -> forall l,
   {c |
    forall x y, 0 <= x -> x <= y -> y <= b ->
    Qabs (eval_pol l y - eval_pol l x) <= c*(y-x)}.
intros b pb; induction l.
exists 0; intros x y px xy yb; simpl; ring_simplify.
assert (d0 : 0-0 == 0) by ring.
rewrite d0; apply Qle_refl.
destruct IHl as [c cp].
exists (eval_pol (Qabs_pol l) b+c*b); intros x y px xy yb; simpl.
match goal with |- Qabs (?e) <= _ =>
  setoid_replace e with
     ((y-x)*eval_pol l y + x*(eval_pol l y - eval_pol l x)) by ring end.
apply Qle_trans with
   (1:= Qabs_plus ((y-x)*eval_pol l y) (x*(eval_pol l y - eval_pol l x))).
rewrite Qmult_plus_distr_l; apply Qplus_le_compat.
assert (xmy: 0 <= y - x).
setoid_replace 0 with (x+ -x) by ring.
unfold Qminus; apply Qplus_le_compat; auto.
rewrite Qabs_mult; rewrite (pos_Qabs (y-x)); auto.
rewrite (Qmult_comm (y-x)); apply Qmult_le_compat_r; auto.
assert (py: 0 <= y) by (apply Qle_trans with x; auto).
apply Qle_trans with (2:= Qabs_pol_increase l y b py yb).
pattern y at 2; rewrite <- (pos_Qabs y py).
apply Qabs_pol_bound.
setoid_replace (c*b*(y-x)) with (b * (c*(y-x))) by ring.
rewrite Qabs_mult; rewrite (pos_Qabs x px).
apply Qle_trans with (b*Qabs (eval_pol l y - eval_pol l x)).
apply Qmult_le_compat_r; auto.
apply Qle_trans with y; auto.
repeat rewrite (Qmult_comm b); apply Qmult_le_compat_r; auto.
Qed.

Definition find_pair : forall A:Type, forall P:A->Prop, forall Q:A->A->Prop,
    forall l:list A, forall a b:A, P a -> ~P b ->
    (forall l1 l2 x y, a::l++b::nil=l1++x::y::l2 -> Q x y) ->
    (forall x, In x l -> {P x}+{~P x}) ->
    {c :A & { d | Q c d /\ P c /\ ~P d}}.
intros A P Q; induction l; simpl; intros a' b' Pa Pb connect dec.
exists a'; exists b'; split; auto.
apply (connect nil nil); auto.
case (dec a); auto.
intros Pa1; destruct (IHl a b' Pa1 Pb) as [c [d [cd [Pc Pd]]]].
intros l1 l2 x y q; apply (connect (a'::l1) l2); rewrite q; simpl;auto.
intros x inx; apply (dec x); auto.
exists c; exists d; auto.
exists a'; exists a; split; auto.
apply (connect nil (l++b'::nil)); auto.
Qed.

Function ns (p n:Z) {measure Zabs_nat n} : list Z :=
   if Z_le_dec n 0 then p::nil else (p-n)%Z::ns p (n-1)%Z.
intros; apply Zabs_nat_lt; omega.
Defined.

Lemma ns_head : forall p n, (0 <= n)%Z -> exists l, ns p n = (p - n)%Z::l.
intros p n; functional induction ns p n.
intros; assert (n = 0)%Z by omega; subst n; ring_simplify (p-0)%Z; exists nil; auto.
intros _; destruct IHl  as [l' pl'].
omega.
exists ((p-(n-1))%Z::l'); rewrite pl'; auto.
Qed.

Lemma ns_step : forall p n, forall l1 l2 x y, (0 <= n)%Z ->
  ns p n = l1++x::y::l2 -> y = (x + 1)%Z.
intros p n; functional induction ns p n.
intros; repeat (destruct l1; try discriminate).
assert (np1 : (0 <= n-1)%Z) by omega.
intros l1 l2 x y np q; destruct l1 as [ | a l1].
destruct (ns_head p (n-1)  np1) as [l' ql'].
rewrite ql' in q; simpl in q; injection q; intros; subst y x; ring.
apply (IHl l1 l2); auto.
simpl in q; injection q; auto.
Qed.

Lemma ns_tail : forall p n, exists l, ns p n = l++p::nil.
intros p n; functional induction ns p n.
exists nil; auto.
destruct IHl as [l ql]; rewrite ql; exists ((p-n)%Z::l); auto.
Qed.

Lemma ns_bounds : forall p n x l1 l2, (0 <= n)%Z -> ns p n = l1++x::l2 ->
        (p -n <= x <= p)%Z.
intros p n; functional induction ns p n.
intros x [ | a l1].
simpl; intros l2 np q; injection q;intros; omega.
intros; destruct l1; discriminate.
intros x [ | a l1];
simpl; intros l2 np q; injection q; intros; try omega.
assert (p - (n-1) <= x <= p)%Z.
apply (IHl x l1 l2); auto; omega.
omega.
Qed.

Lemma map_contiguous :
forall A B : Type, forall f : A -> B, forall l,
forall l1 l2 a b, map f l = l1++a::b::l2 ->
  {l'1 :list A & {l'2 : list A & {x:A & {y:A | l1 = map f l'1 /\ l2= map f l'2 /\ a = f x /\
        b = f y /\ l = l'1++x::y::l'2}}}}.
intros A B f l; induction l.
simpl; intros; destruct l1; discriminate.
intros l1 l2 b1 b2; destruct l1 as [ | a' l1].
  simpl; intros q.
destruct l as [|a'' l]; try discriminate q; simpl in q.
injection q; intros.
exists nil; exists l; exists a; exists a''; auto.
simpl; intros q.
injection q; intros q' q''.
destruct (IHl _ _ _ _ q') as [r1 [r2 [x [y [q1 [ q2 [qx [qy ql]]]]]]]].
exists (a::r1); exists r2; exists x; exists y; repeat apply conj; auto.
simpl; rewrite q'', q1; auto.
simpl; rewrite ql; auto.
Qed.

Lemma map_app :
  forall A B:Type, forall f : A -> B, forall l1 l2, map f (l1++l2) = map f l1 ++ map f l2.
intros A B f l1; induction l1; simpl; auto.
intros l2; rewrite IHl1; auto.
Qed.

Lemma non_empty_tail :
  forall (A:Type) (a:A) l, exists l', exists b, a::l = l'++(b::nil).
intros A a l; generalize a; clear a; induction l.
exists nil; exists a; auto.
intros a'; destruct (IHl a) as [l' [b q]]; rewrite q.
exists (a'::l'); exists b; auto.
Qed.

Lemma Qfrac_add_Z_l : forall a b c, (a#1) + (b#c) == (a*'c+b#c).
intros;unfold Qeq; simpl; ring.
Qed.

Lemma constructive_mvt :
  forall l x y, x < y -> eval_pol l x < 0 -> 0 <= eval_pol l y  ->
       forall epsilon, 0 < epsilon ->
       exists x', exists y',  -epsilon <= eval_pol l x' /\
         eval_pol l x' < 0 /\ 0 <= eval_pol l y' /\
         eval_pol l y' <= epsilon /\ x <= x' /\ x' < y' /\ y' <= y.
intros l a b ab nla plb.
destruct (translate_pol l a) as [l' q].
assert (ba':0 < b-a).
setoid_replace 0 with (a-a) by ring.
unfold Qminus; repeat rewrite <- (Qplus_comm (-a));
apply Qplus_le_lt_compat; auto.
assert (ba:~ b-a == 0).
intros abs; case (Qlt_not_eq 0 (b-a) ba'); rewrite abs; apply Qeq_refl.
destruct (cm3 (b-a) ba' l') as [c pc].
assert (mpolapos : 0 < -eval_pol l a) by (apply Qopp_lt_lr; assumption).
assert (t1 : a-a == 0) by ring.
assert (cpos: 0 < c).
setoid_replace 0 with (0 */(b-a)) by ring.
setoid_replace c with ((c*(b-a-(a-a)))/(b-a)) by (field;auto).
apply Qmult_lt_compat_r; auto.
apply Qlt_le_trans with (Qabs (eval_pol l' (b-a) - eval_pol l' (a-a))).
match goal with |- 0 < Qabs(?a) => assert (ineq: 0 < a) end.
repeat rewrite <- q; setoid_replace 0 with (0+0) by ring.
apply Qplus_le_lt_compat; auto.
rewrite pos_Qabs; auto.
apply pc; try solve[rewrite t1; auto | auto].
assert (cn0 : ~c==0) by (apply Qnot_eq_sym; apply Qlt_not_eq ; auto).
intros epsilon pe.
assert (en0 : ~ epsilon == 0) by (apply Qnot_eq_sym; apply Qlt_not_eq; auto).
assert (pdiv: 0 < (b-a)*c/epsilon) by (repeat apply Qmult_lt_0_compat; auto).
destruct (QZ_bound ((b-a)*c/(epsilon))) as [n qn]; auto.
assert (pn : (0 < n)%Z).
destruct ((b-a)*c/epsilon) as [nu de]; unfold Qle in qn, pdiv;
simpl in qn, pdiv.  unfold Qlt in pdiv; simpl in pdiv; rewrite Zmult_1_r in pdiv, qn.
assert (pdiv' := Zlt_le_trans _ _ _ pdiv qn).
apply Zmult_lt_0_reg_r with ('de)%Z; try solve [compute; auto with zarith].
assert (mkl:
  exists l, forall l1 l2 x y, a::l++b::nil = l1++x::y::l2 ->
      y-x == (b-a)/(n#1) /\ exists k, x == a + (b-a)*(k#1)/(n#1) /\ (0<= k <= n-1)%Z).
case (Z_eq_dec n 1).
intros n1; exists nil; intros l1 l2 x y; destruct l1; simpl;
  intros ql.
injection ql; intros; subst x y n; split;
 [field | exists 0%Z; split; [field | omega]].
repeat (destruct l1; try discriminate).
intros nn1; exists (map  (fun x => a + (b-a)*((x#1)/(n#1))) (ns (n-1) (n-2))).
intros l1 l2  x y; destruct l1.
assert (0 <= n-2)%Z by omega.
destruct (ns_head (n-1) (n-2)) as [a1 qa1];auto; rewrite qa1; simpl.
replace ((n-1)-(n-2))%Z with 1%Z by ring.
intros ql; injection ql; intros; subst x y; split.
field; unfold Qeq; simpl; omega.
exists 0%Z; split;[field; unfold Qeq; simpl; omega | omega].
simpl; intros q'; injection q'; clear q'.
destruct l2 as [| d l2].
replace (x::y::nil) with ((x::nil)++(y::nil)). rewrite  <- app_ass.
intros q' _; elim (app_inj_tail  _ _ _ _ q'); clear q'; intros q' q''.
destruct (ns_tail (n-1)(n-2)) as [l3 ql3].
rewrite ql3 in q'.
rewrite map_app in q'; simpl in q'.
elim (app_inj_tail _ _ _ _ q'); clear q'; intros q' q3'.
subst x y.
assert (t0:(n-1#1)/(n#1) == 1 - /(n#1)).
setoid_replace 1 with ((n#1)/(n#1)).
setoid_replace (/(n#1)) with (1/(n#1)).
unfold Qdiv.
match goal with |- _ == ?a =>
    setoid_replace a with (((n#1) - 1) * /(n#1)) by ring end.
apply Qmult_comp.
unfold Qeq; simpl; ring.
apply Qeq_refl.
field; unfold Qeq; simpl; omega.
field; unfold Qeq; simpl; omega.
rewrite t0.
split.
field; unfold Qeq; simpl; omega.
exists (n-1)%Z; split.
unfold Qdiv; rewrite Qmult_assoc; apply Qeq_refl.
omega.
simpl; auto.
unfold Qdiv.
destruct (non_empty_tail  _ d l2) as [l3 [e qe]].
rewrite qe.
replace (l1++x::y::l3++e::nil) with ((l1++x::y::l3)++(e::nil)).
intros q' _.
destruct (app_inj_tail _ _ _ _ q') as [q'' _].
destruct (map_contiguous _ _ (fun x => a+(b-a)*((x#1)*/(n#1)))
             _ _ _ _ _ q'') as [l'1 [l'2 [n1 [n2 [_ [_ [qx [qy st]]]]]]]].
subst x y; setoid_replace (n2#1) with ((n1#1)+1).
split.
ring.
exists n1; split.
rewrite Qmult_assoc; apply Qeq_refl.
apply ns_bounds in st; omega.
rewrite Qfrac_add_Z_l; rewrite Zmult_1_r.
apply ns_step in st; try omega; rewrite st; apply Qeq_refl.
rewrite app_ass; auto.
destruct mkl as [sl qsl].
destruct (find_pair Q (fun x => eval_pol l x < 0)
                  (fun x y => y - x == (b-a)/(n#1) /\
                     exists k, x == a + (b-a)*(k#1) /(n#1) /\
                     (0 <= k <= n-1)%Z)
                 sl a b)
  as [a' [b' [[A1 [k [A4 A5]]][A2 A3]]]]; auto.
apply Qle_not_lt; auto.
intros x _; case (Qlt_le_dec (eval_pol l x) 0); auto.
intros H; right; apply Qle_not_lt; auto.
clear qsl sl.
exists a'; exists b'.
assert (aa':a <= a').
(setoid_replace a with (a+0) by ring); rewrite A4.
apply Qplus_le_compat; try apply Qle_refl.
repeat apply Qmult_le_0_compat; auto.
unfold Qle; simpl; omega.
apply Qlt_le_weak; apply Qinv_lt_0_compat; unfold Qlt; simpl; omega.
assert (bb': b' <= b).
setoid_replace b with (a + (b-a) * (n#1) * /(n#1)) by
 field; unfold Qeq; simpl; try omega.
(setoid_replace b' with (a' + (b' - a')) by ring); rewrite A1, A4.
rewrite <- Qplus_assoc; apply Qplus_le_compat; try apply Qle_refl.
unfold Qdiv;
 match goal with |- ?f <= _ => setoid_replace f with ((b-a)* ((k#1)+1) * /(n#1))
 end.
apply Qmult_le_compat_r.
repeat rewrite (Qmult_comm (b-a)); apply Qmult_le_compat_r.
rewrite Qfrac_add_Z_l; unfold Qle; simpl; omega.
auto.
apply Qlt_le_weak; apply Qinv_lt_0_compat; unfold Qlt; simpl; omega.
field; unfold Qeq; simpl; omega.
assert (ab': a' < b').
setoid_replace a' with (a' + 0) by ring.
(setoid_replace b' with (a' + (b' - a')) by ring); rewrite A1.
apply Qplus_le_lt_compat; try apply Qle_refl; apply Qmult_lt_0_compat; auto.
apply Qinv_lt_0_compat; unfold Qlt; simpl; omega.
assert (epsban: (b-a)*c / (n#1) <= epsilon).
apply Qmult_lt_0_le_reg_r with ((n#1) / epsilon).
apply Qmult_lt_0_compat; auto.
unfold Qlt; simpl; omega.
match goal with |- ?f1 <= ?f2 =>
  (setoid_replace f2 with (n#1) by field; auto);
  (setoid_replace f1 with ((b-a)*c /epsilon) by
   (field; split; auto; unfold Qeq; simpl; omega)); auto
end.
split;[idtac | split; auto].
(* start with epsilon and a'. *)
apply Qopp_le_rl.
apply Qle_trans with (eval_pol l b' - eval_pol l a').
setoid_replace (-eval_pol l a') with (0 - eval_pol l a') by ring.
apply Qplus_le_compat; auto; apply Qnot_lt_le; auto.
repeat rewrite q.
rewrite <- (pos_Qabs (eval_pol l' (b'-a) - eval_pol l' (a'-a))).
apply Qle_trans with (c*((b'-a)-(a'-a))).
apply pc; auto.
(setoid_replace 0 with (a - a) by ring); apply Qplus_le_compat; auto; apply Qle_refl.
apply Qplus_le_compat; auto.
apply Qplus_le_compat; auto.
setoid_replace (b' -a -(a'-a)) with (b' -a') by ring.
rewrite A1.
unfold Qdiv; rewrite Qmult_assoc; rewrite (Qmult_comm c); exact epsban.
repeat rewrite <- q.
(setoid_replace 0 with (0+0) by ring);apply Qplus_le_compat.
apply Qnot_lt_le; auto.
apply Qopp_le_lr.
(setoid_replace 0 with (-0) by ring);apply Qlt_le_weak; assumption.
split.
apply Qnot_lt_le; auto.
split; auto.
apply Qle_trans with (eval_pol l' (b' -a) -eval_pol l' (a' -a)).
setoid_replace (eval_pol l b') with (eval_pol l b' + 0) by ring.
apply Qplus_le_compat.
rewrite q; apply Qle_refl.
rewrite <- q; apply Qopp_le_lr; auto.
rewrite <- (pos_Qabs (eval_pol l' (b'-a) - eval_pol l' (a'-a))).
apply Qle_trans with (c*((b'-a)-(a'-a))).
apply pc; auto.
(setoid_replace 0 with (a - a) by ring); apply Qplus_le_compat; auto; apply Qle_refl.
apply Qplus_le_compat; auto.
apply Qplus_le_compat; auto.
setoid_replace (b' -a -(a'-a)) with (b' -a') by ring.
rewrite A1.
unfold Qdiv; rewrite Qmult_assoc; rewrite (Qmult_comm c); exact epsban.
repeat rewrite <- q.
(setoid_replace 0 with (0+0) by ring);apply Qplus_le_compat.
apply Qnot_lt_le; auto.
apply Qopp_le_lr.
apply Qlt_le_weak; assumption.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.
From adtind Require Import goal41.

Set Printing Depth 1000.
Definition lfind_eval  x n:=
lst_mem n x.

Compute lfind_eval  (Cons (Succ (Succ Zero)) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))))) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) Nil)) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ Zero) Nil)))) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ Zero) Nil)) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero Nil)) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil))) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil)))) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e255m765_4limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Main.
Require Import Cat.Cat.
Require Import Basic_Cons.Terminal.
Require Import Archetypal.Discr.Discr.

Local Hint Extern 1 => cbn in *.
Local Hint Extern 1 => match goal with [c : Empty |- _] => destruct c end.

(** The unique functor from the initial category to any other. *)
Program Definition Functor_From_Empty_Cat (C' : Category) : (0 –≻ C')%functor :=
{|
  FO := fun x => Empty_rect _ x;
  FA := fun a b f => match a as _ return _ with end
|}.

Definition EmptyCat_Cat : Cat.
Proof.
  refine (existT _ 0%category _).
  intros [].
Defined.

(** Empty Cat is the initial category. *)
Definition Cat_Init : Initial Cat.
Proof.
  refine
    (
      Build_Terminal
        (Cat ^op)
        EmptyCat_Cat
        (fun x => Functor_From_Empty_Cat x.1)
        _
    ); auto
  .
Defined.


Require Import Reals Interval.Tactic.

Goal forall x : R,
  (Rabs (x - x) <= 1/5)%R.
Proof.
intros x.
interval with (i_autodiff x, i_prec 10).
Qed.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                            2004 -2005                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Require Export listAux.
Require Export Arith.
Require Export basics.
Set Implicit Arguments.
Global Set Asymmetric Patterns.

Section allSem.
Variables I J A:Set.

Inductive semType :Set :=
| e :semType  (* type des individus*)
| t : semType  (* valeurs de verite *)
| funAppli :semType -> semType -> semType (* type fonctionnel *)
| cartProd:semType -> semType -> semType  (* produit cartesien *)
|intention :semType->semType. (* le type s->t cf.Gamut *)

Definition eqDecSem:forall (t1 t2:semType), {t1=t2}+{t1 <>t2}.
decide equality.
Defined.
(* map is a function that maps a semantic type to each atomic one *)
Variable map:A->semType.

(* function that maps a semantic type to each syntactic one *)
Fixpoint mapExt (f:Form I J A){struct f}:semType :=
match f with
| At p => map p
| Slash _ f1 f2 => funAppli (mapExt f2) (mapExt f1)
| Backslash _ f1 f2 =>funAppli (mapExt f1) (mapExt f2)
| Dot _ f1 f2 => cartProd (mapExt f1) (mapExt f2)
| Box _ f1 => (intention (mapExt f1))
| Diamond _ f1 => (intention (mapExt f1))
end.

Section lambdaX.
(* In this section X represents the set of constants of our lambda-calculus*)
Variable X:Set.
Variable getSemTypeX : X->semType.

(* definition of typed lambda terms *)
Inductive lambda_terms:Set:=
| num : nat -> lambda_terms (* numbers for bound variables *)
| ress : X ->lambda_terms (* set of constants used *)
| hyps: nat->semType->lambda_terms (* free variables *)
| appl :lambda_terms -> lambda_terms -> lambda_terms (* application *)
| abs : semType ->lambda_terms  -> lambda_terms (* abstraction, the first type is the type of the bound variable *)
| twoL : lambda_terms -> lambda_terms  -> lambda_terms (* pair of two lambda-terms *)
| pi1 :lambda_terms -> lambda_terms  (* first projection *)
| pi2 : lambda_terms -> lambda_terms (* second projection *)
| box : lambda_terms -> lambda_terms (* intentionality operators *)
| debox : lambda_terms -> lambda_terms
| diam : lambda_terms -> lambda_terms
| dediam :lambda_terms -> lambda_terms.

(* function that tests whether a term is well formed:
all variables represented by integers are bound and there is no
 leaf of the form (hyps ...),
thus, the term (abs ty (num 0)) is well formed whereas (num 0) is not *)
Fixpoint isWellFormedN (n:nat) (l:lambda_terms){struct l} :Prop:=
match l with
| num  k =>match (le_lt_dec n k) with
                            | right _ => True  (* k<n*)
                            | left _ => False (* n <= k *)
             end
| ress  r => True
|hyps _ _ => True
| appl  l1 l2 => isWellFormedN n l1 /\ isWellFormedN n l2
| abs _ l1 => isWellFormedN (S n) l1
| twoL  l1 l2 => isWellFormedN n l1 /\ isWellFormedN n l2
| pi1  l1 => isWellFormedN n l1
| pi2  l1 => isWellFormedN n l1
| box  l1 => isWellFormedN n l1
| debox  l1 => isWellFormedN n l1
| diam  l1 => isWellFormedN n l1
| dediam  l1 => isWellFormedN n l1
end.

Definition isWellFormed(l:lambda_terms):=(isWellFormedN O l).

Fixpoint no_hyps_inside (l:lambda_terms):Prop:=
match l with
|hyps _ _=> False
| num  k =>True
| ress  r => True
| appl  l1 l2 => no_hyps_inside l1 /\ no_hyps_inside l2
| abs _ l1 => no_hyps_inside l1
| twoL  l1 l2 => no_hyps_inside l1 /\ no_hyps_inside l2
| pi1  l1 => no_hyps_inside l1
| pi2  l1 => no_hyps_inside l1
| box  l1 => no_hyps_inside l1
| debox  l1 => no_hyps_inside l1
| diam  l1 => no_hyps_inside l1
| dediam  l1 => no_hyps_inside l1
end.

(* some useful functions *)
(* binds the hypsothesis (hyps n st) *)
Fixpoint lambdaBind (lTerm:lambda_terms)(i n:nat)(st:semType){struct lTerm}:lambda_terms :=
match lTerm with
| num l => if (le_lt_dec i l) then (num (S l)) else (num l)
| ress  r =>ress r
| hyps k s=> if (eq_nat_dec k n)
           then (if (eqDecSem s st) then (num i) else (hyps k s))
           else (hyps k s)
| appl t1 t2 => appl  (lambdaBind t1 i n st) (lambdaBind t2 i n st)
| abs ty t1 => abs ty (lambdaBind t1 (S i) n st)
| twoL t1 t2  =>  twoL  (lambdaBind t1 i n st) (lambdaBind t2 i n st)
| pi1  t1=>pi1  (lambdaBind t1 i n st)
| pi2  t1 => pi2  (lambdaBind t1 i n st)
| box  t1 =>box  (lambdaBind t1 i n st)
| debox  t1 => debox (lambdaBind t1 i n st)
| diam  t1 => diam  (lambdaBind t1 i n st)
| dediam t1 => dediam  (lambdaBind t1 i n st)
end.

(* function that abstract the variable x*)
Definition lambdaAbs(lTerm:lambda_terms)(n :nat)(st:semType):lambda_terms
 :=(abs st (lambdaBind lTerm O n st)).

Fixpoint up_lambda (l:lambda_terms)(n:nat)(i:nat){struct l}:lambda_terms:=
match l with
|num  m=>match (le_lt_dec i m) with
            |left _ =>num  (m+n)  (* in this case m>=i*)
            |right _=>num  m
             end
|ress  r => ress  r
|hyps k s=>hyps k s
|appl  l1 l2=> appl  (up_lambda l1 n i) (up_lambda l2 n i)
|abs ty l1 => abs ty (up_lambda l1 n (S i))
| twoL l1 l2 =>twoL  (up_lambda l1 n i) (up_lambda l2 n i)
| pi1  l1 => pi1  (up_lambda l1 n i)
|pi2  l1 => pi2  (up_lambda l1 n i)
| box  l1 => box  (up_lambda l1 n i)
|debox  l1 =>debox (up_lambda l1 n i)
|diam  l1=>diam (up_lambda l1  n i)
|dediam  l1 =>dediam  (up_lambda l1 n i)
end.

Definition lift_lambda(l:lambda_terms)(n:nat):lambda_terms:=
(up_lambda l n 0).

Lemma lift_wf:forall (l:lambda_terms)(k n:nat),
                 isWellFormedN n l->
                 up_lambda l k n=l.
 Proof.
 intros l k; elim l; simpl in |- *; intros; auto.
 generalize H; case (le_lt_dec n0 n).
 induction 2.
 auto.
 decompose [and] H1.
 rewrite (H _ H2); rewrite (H0 _ H3).
 auto.
 rewrite (H _ H0).
 auto.
 decompose [and] H1.
 rewrite (H _ H2); rewrite (H0 _ H3); auto.
 rewrite H; auto.
 rewrite H; auto.
 rewrite H; auto.
 rewrite H; auto.
 rewrite H; auto.
 rewrite H; auto.
Qed.

(* substitution of an hypsothesis of the form (hyps n st) by lTerm2 in
the lambda term lTerm1 *)
Fixpoint lambdaSubN (lTerm1 lTerm2:lambda_terms)(i n:nat)(st:semType){struct lTerm1}:lambda_terms:=
match lTerm1 with
| num l=> (num l)
| ress  r => ress r
| hyps k s=>if (eq_nat_dec k n)
           then (if (eqDecSem s st) then (lift_lambda lTerm2 i) else
	   (hyps k s))
           else (hyps k s)
| appl t1 t2 => appl (lambdaSubN t1 lTerm2 i n st) (lambdaSubN t2
lTerm2 i n st)
| abs ty t1 => abs ty (lambdaSubN t1 lTerm2 (S i) n st)
| twoL  t1 t2 => twoL  (lambdaSubN t1 lTerm2 i n st) (lambdaSubN t2
lTerm2 i n st)
| pi1  t1 =>pi1  (lambdaSubN t1 lTerm2 i n st)
| pi2  t1 =>pi2  (lambdaSubN t1 lTerm2 i n st)
| box  t1 =>box  (lambdaSubN t1 lTerm2 i n st)
| debox  t1 =>debox  (lambdaSubN t1 lTerm2 i n st)
| diam  t1 =>diam  (lambdaSubN t1 lTerm2 i n st)
|dediam t1 =>dediam  (lambdaSubN t1 lTerm2 i n st)
end.

Definition lambSub (lTerm1 lTerm2:lambda_terms)(n:nat)(st:semType):lambda_terms:=
                         lambdaSubN lTerm1 lTerm2 0 n st.

(* typeness *)
Inductive isWellTyped :(list semType)->lambda_terms->semType ->Set:=
| typeNum: forall (env:list semType) (n:nat)(ty:semType),
                    nth_error env n=Some ty ->
                    isWellTyped env (num n) ty
| typeVar :forall (x:X)(env:list semType) ,
                  isWellTyped env (ress x) (getSemTypeX x)
|typeHyps:forall (n:nat)(ty:semType)env, isWellTyped env (hyps n ty) ty
| typeAppl : forall (l1 l2: lambda_terms)(t1 t2:semType)(env:(list semType)),
                  isWellTyped env l1 (funAppli t1 t2) ->
                  isWellTyped env l2 t1 ->
                  isWellTyped env (appl l1 l2) t2
| typeAbs : forall (l1:lambda_terms)( t1 t2:semType)(env:list semType),
                  isWellTyped (t2::env) l1 t1->
                  isWellTyped env (abs t2 l1) (funAppli t2 t1)
| typeTwoL: forall  (l1 l2: lambda_terms)(t1 t2:semType)(env:(list semType)),
                  isWellTyped env l1  t1  ->
                  isWellTyped env l2 t2 ->
                  isWellTyped env (twoL l1 l2)  (cartProd t1 t2)
| typePi1:forall (l1:lambda_terms)(t1 t2 :semType)(env:list semType),
                 isWellTyped env l1 (cartProd t1 t2)->
                 isWellTyped env (pi1 l1) t1
| typePi2 :forall (l1:lambda_terms)(t1 t2 :semType)(env:list semType),
                 isWellTyped env l1 (cartProd t1 t2)->
                 isWellTyped env (pi2 l1) t2
|typeBox:forall (l1:lambda_terms) (t1:semType)(env:list semType),
                 isWellTyped env l1 t1->
                 isWellTyped env (box l1) (intention t1)
|typeDebox:forall (l1:lambda_terms)(t1:semType) (env:list semType),
                 isWellTyped env l1 (intention t1)->
                 isWellTyped env (debox l1) t1
|typeDiam:forall (l1:lambda_terms)(t1:semType) (env:list semType),
                 isWellTyped env l1 t1->
                 isWellTyped env (diam l1) (intention t1)
|typeDediam:forall (l1:lambda_terms)(t1:semType) (env:list semType),
                 isWellTyped env l1 (intention t1)->
                 isWellTyped  env (dediam l1) t1.

Fixpoint type_check (env:list semType)(l:lambda_terms){struct l} :
 (option semType):=
match l with
| num n => nth_error env n
| ress r => Some (getSemTypeX r)
| hyps k ty=> Some ty
| appl l1 l2 => match (type_check env l1) with
                | Some (funAppli t1 t2) => match (type_check env l2) with
                                           | Some t'1 => match (eqDecSem t1 t'1) with
                                                        | left _ => Some t2
                                                        | right _ => None
                                                       end
                                           | None => None
                                           end
                |others => None
                 end
| abs t1 l1 => match (type_check (t1::env) l1) with
              | Some t2 => Some (funAppli t1 t2)
              | None => None
             end
|twoL l1 l2 => match (type_check env l1) with
       |Some t1 => match (type_check env l2) with
           |Some t2 => Some (cartProd t1 t2)
           | None => None
           end
       |None => None
         end
| pi1 l1=> match (type_check env l1) with
              |Some (cartProd t1 t2) => Some t1
              |others => None
            end
| pi2 l1=> match (type_check env l1) with
              |Some (cartProd t1 t2) => Some t2
              |others => None
            end
|box l1=>match (type_check env l1) with
         |Some t1 => Some (intention t1)
         |None => None
       end
|debox l1=>match (type_check env l1) with
           |Some (intention t1) => Some t1
           |others => None
       end
|diam l1=>match (type_check env l1) with
         |Some t1 => Some (intention t1)
         |None => None
       end
|dediam l1=>match (type_check env l1) with
           |Some (intention t1) => Some t1
           |others => None
       end
end.

(* a useful tactic *)
Ltac disc:=
 match goal with
| H: None = Some _ |- _ =>
 discriminate H
end.

(* some inversion lemmas *)
Lemma getTypeAppl :forall (l1 l2:lambda_terms)(env :list semType)(t1:semType),
                   type_check env (appl l1 l2) =Some t1 ->
                  {t2:semType | (type_check env l1 = (Some (funAppli t2 t1))) /\
                   (type_check env l2 = (Some t2))}.
Proof.
intros.
generalize H;clear H.
simpl;elim (type_check env l1); elim (type_check env l2).
intros a a0; case a0.
intro H2; discriminate H2.
intro H2; discriminate H2.
intros s s0; elim (eqDecSem s a).
intros.
exists s.
rewrite a1; injection H; intro R; rewrite R; tauto.
intros H H1; discriminate H1.
intros s s0 H1; discriminate H1.
intros H H1; discriminate H1.
intro a; elim a; intros; disc.
intros.
 discriminate H.
intro H; discriminate H.
Defined.

Lemma getTypeTwoL:forall (l1 l2:lambda_terms)(env :list semType)(t1:semType),
                             type_check env (twoL l1 l2) =Some t1 ->
                             {t'1: semType & { t'2:semType |t1 =cartProd t'1 t'2 /\
                              type_check env l1 =Some t'1 /\
                              type_check env l2 =Some t'2}}.
Proof.
intros.
generalize H; clear H; simpl;
 elim (type_check env l1); elim (type_check env l2).
intros.
exists a0; exists a.
injection H; intro R; rewrite R;tauto.
intros; disc.
intros; disc.
intros ; disc.
Defined.

Lemma getTypePi1:forall (l1:lambda_terms)(env:list semType)(t1:semType),
                        (type_check env (pi1 l1)) = Some t1 ->
                        {t2:semType|(type_check env l1) =
                                           Some (cartProd t1 t2)}.
Proof.
intros.
generalize H; clear H;simpl.
elim (type_check env l1).
intro a; elim a; intros; try disc.
exists s0; injection H1; intro R; rewrite R.
auto.
intro; disc.
Defined.

Lemma getTypePi2:forall (l1:lambda_terms)(env:list semType)(t1:semType),
                        (type_check env (pi2 l1)) = Some t1 ->
                        {t2:semType|(type_check env l1) =
                                   Some (cartProd t2 t1)}.
Proof.
intros.
generalize H; clear H;simpl.
elim (type_check env l1).
intro a; elim a; intros; try disc.
exists s; injection H1; intro R; rewrite R.
auto.
intro; disc.
Defined.

Lemma getTypeAbs: forall (l1 :lambda_terms)(t1 t2:semType)(env:list semType),
                     type_check env (abs t1 l1)=Some t2 ->
                     {t'1:semType| t2=funAppli t1 t'1 /\
                                          type_check (t1::env) l1 =Some t'1}.
Proof.
intros.
generalize H.
clear H; simpl.
case (type_check (t1::env) l1).
intros s H; injection H; intro R; rewrite <- R.
exists s;tauto.
intro; disc.
Defined.

Lemma getTypeBox:forall (l1:lambda_terms)(t1:semType)(env:list semType),
                     type_check env (box l1)=Some t1->
                     { t'1:semType| t1=intention t'1/\ type_check env l1 =Some t'1}.
Proof.
 intros.
 generalize H; clear H; simpl in |- *.
 elim (type_check env l1).
 intros.
 injection H.
 intro.
 exists a; split.
 rewrite H0; reflexivity.
 auto.
 intro H1; discriminate H1.
Defined.

Lemma getTypeDiam:forall (l1:lambda_terms)(t1:semType)(env:list semType),
                     type_check env (diam l1)=Some t1->
                     {t'1:semType| t1=intention t'1/\
                      type_check env l1 =Some t'1}.
Proof.
 intros.
 generalize H; clear H; simpl in |- *.
 elim (type_check env l1).
 intros.
 injection H.
 intro.
 exists a; split.
 rewrite H0; reflexivity.
 auto.
 intro H1; discriminate H1.
Defined.

Lemma getTypeDebox:forall (l1:lambda_terms)(t1:semType)(env:list semType),
                    type_check env (debox l1)=Some t1->
                    type_check env l1=Some (intention t1).
Proof.
 intros l1 t1 env.
 simpl in |- *.
 elim (type_check env l1).
 intro a.
 case a; intros; try disc.
 injection H; intro R; rewrite R; auto.
 intro; disc.
Defined.

Lemma getTypeDediam:forall (l1:lambda_terms)(t1:semType)(env:list semType),
                   type_check env (dediam l1)=Some t1->
                   type_check env l1=Some (intention t1).
Proof.
 intros l1 t1 env.
 simpl in |- *.
 elim (type_check env l1).
 intro a.
 case a; intros; try disc.
 injection H; intro R; rewrite R; auto.
 intro; disc.
Defined.

Lemma type_check_wellTyped:forall (l1:lambda_terms)(env:list semType) (t1:semType),
                        type_check env l1= Some t1->
                         isWellTyped env l1 t1.
Proof.
intro l1; elim l1;intros.
simpl in H.
constructor.
auto.
simpl in H.
injection H.
intro R;rewrite <-R;constructor.
simpl in H;injection H;intro R.
rewrite <- R; constructor.
elim (getTypeAppl _ _ _ H1).
intros x H2.
elim H2; intros.
econstructor; eauto.
elim (getTypeAbs _ _ _ H0).
intros x H1.
elim H1; intros R H2; rewrite R.
constructor.
apply H;auto.
elim (getTypeTwoL _ _ _ H1).
intros x H2.
elim H2;  intros x0 H3.
elim H3; intros H4 H5.
rewrite H4; elim H5; intros; constructor;auto.
elim (getTypePi1 _ _  H0).
intros.
econstructor;eauto.
elim (getTypePi2 _ _ H0); intros; econstructor; eauto.
elim (getTypeBox _ _ H0).
intros x H1.
elim H1; clear H1; intros.
subst.
constructor.
eauto.
constructor.
apply H.
apply getTypeDebox; auto.
elim (getTypeDiam _ _ H0).
intros x H1.
elim H1; clear H1; intros.
subst.
constructor.
auto.
constructor.
apply H; apply getTypeDediam.
auto.
Defined.

Lemma wellTyped_type_check:forall (l1:lambda_terms)(env:list semType) (t1:semType),
                   isWellTyped env l1 t1->
                   type_check env l1= Some t1.
Proof.
 induction 1.
 simpl in |- *; auto.
 simpl in |- *; auto.
 auto.
 simpl in |- *; rewrite IHisWellTyped1;
 rewrite IHisWellTyped2; auto.
 case (eqDecSem t1 t1).
 auto.
 induction 1; auto.
 simpl in |- *.
 rewrite IHisWellTyped.
 auto.
 simpl in |- *; rewrite IHisWellTyped1;
 rewrite IHisWellTyped2; auto.
 simpl in |- *.
 rewrite IHisWellTyped; auto.
 simpl in |- *; rewrite IHisWellTyped; auto.
 simpl in |- *; rewrite IHisWellTyped; auto.
 simpl in |- *; rewrite IHisWellTyped; auto.
 simpl in |- *; rewrite IHisWellTyped; auto.
 simpl in |- *; rewrite IHisWellTyped; auto.
Defined.

Lemma one_type:forall (l:lambda_terms) (t1 t2:semType)(env:list semType),
                     isWellTyped env l t1  ->
                     isWellTyped env l t2 ->
                      t1 =t2.
Proof.
 intros; cut (Some t1 = Some t2).
 injection 1; auto.
 rewrite <- (wellTyped_type_check H); rewrite <- (wellTyped_type_check H0).
 auto.
Qed.

Inductive add_ith_list (A:Set)(a:A):list A->list A->nat->Prop:=
|add_0:forall l1, add_ith_list a l1 (a::l1) 0
|add_next:forall l1 l2 i b , add_ith_list a l1 l2 i->add_ith_list a
(b::l1)(b::l2) (S i).

(* some lemmas about this predicate *)
Lemma nth_add1:forall (A:Set)(l1 l2:list A)(i:nat)a b,
                 add_ith_list a l1 l2 i->
              forall (n:nat), n>=i->
              nth_error  l1 n=Some b->
              nth_error l2 (S n) =Some b.
Proof.
 induction 1.
 simpl in |- *; auto.
 simpl in |- *.
 intros.
 generalize H0 H1; clear H0 H1; case n; intros.
 inversion H0.
 simpl in H1.
 eauto with arith.
Qed.

Lemma nth_add2:forall (A:Set)(l1 l2:list A)(i:nat)a b,
                 add_ith_list a l1 l2 i->
              forall (n:nat), n<i->
              nth_error l1 n=Some b->
              nth_error l2 n =Some b.
Proof.
 induction 1.
 inversion 1.
 intro n; case n; simpl in |- *; intros.
 auto.
 eauto with arith.
Qed.

Lemma nth_add3:forall (A:Set)(l1 l2:list A)(i:nat)a ,
                 add_ith_list a l1 l2 i->
                nth_error l2 i=Some a.
induction 1;simpl;auto.
Qed.

(* Some lemmas concerning the predicate isWellFormed *)
Lemma wellFLe1:forall (n m:nat), lt n m ->
                                isWellFormedN m (num  n).
Proof.
 intros.
 simpl in |- *.
 elim (le_lt_dec m n); intro.
 absurd (m <= n); auto with arith.
 auto.
Qed.

Lemma wellFLe2:forall (n m:nat),isWellFormedN m (num  n)->
                                lt n m.
Proof.
 intros n m .
 simpl in |- *.
 elim (le_lt_dec m n).
 tauto.
 auto.
Qed.

Lemma notWellFormedNum:forall (n:nat), isWellFormed (num  n) ->
                                       False.
Proof.
 intros n H.
 unfold isWellFormed in H.
 cut (n < O).
 intro; auto with arith.
 apply wellFLe2  ; auto.
Qed.

Lemma wellFLe: forall (l:lambda_terms)(n m:nat), n <= m ->
                                        (isWellFormedN n l)->
                                        (isWellFormedN m l).
Proof.
 intro l; elim l; intros.
 apply wellFLe1.
 eapply lt_le_trans.
 eapply wellFLe2; eauto.
 auto.
 simpl in |- *; auto.
 simpl in |- *; auto.
 simpl in H2; elim H2; clear H2; intros; simpl in |- *;split; eauto.
 simpl in H1.
 simpl in |- *.
 apply (H (S n) (S m)).
 auto with arith.
 auto.
 simpl in |- *.
 simpl in H2; elim H2; intros;split;eauto.
 simpl in |- *;simpl in H1;eauto.
 simpl in |- *; simpl in H1; eauto.
 simpl in |- *; simpl in H1; eauto.
 simpl in |- *; simpl in H1; eauto.
 simpl in |- *; simpl in H1; eauto.
 simpl in |- *; simpl in H1; eauto.
Qed.

Lemma isWellFormedBindN:forall (l:lambda_terms)(i n:nat)(st:semType),
                            isWellFormedN i l->
                            isWellFormedN (S i) (lambdaBind l i n st).
Proof.
 intro l; elim l; intros.
 simpl lambdaBind.
 case (le_lt_dec i n).
 intro; apply wellFLe1.
 cut (n < i).
 auto with arith.
 eapply wellFLe2; eauto.
 intro; apply wellFLe1; auto with arith.
 simpl in |- *;auto.
 simpl in |- *.
 case (eq_nat_dec n n0).
 case (eqDecSem s st).
 intros; apply wellFLe1; auto with arith.
 simpl in |- *; auto.
 auto.
 simpl in |- *.
 auto.
 simpl in |- *;simpl in H1; elim H1;intros;  split; eauto.
 simpl; simpl in H0; intros; eauto.
 simpl in |- *;elim H1; intros;split; eauto.
 simpl in |- *; simpl in H0; intros; eauto.
 simpl in |- *; simpl in H0; intros; eauto.
 simpl in |- *; simpl in H0; intros; eauto.
 simpl in |- *; simpl in H0; intros; eauto.
 simpl in |- *; simpl in H0; intros; eauto.
 simpl in |- *; simpl in H0; intros; eauto.
Qed.

Lemma isWellFormedBind: forall (l:lambda_terms)(n:nat)(st:semType),
                       isWellFormed l ->
                       isWellFormed (lambdaAbs l n st).
Proof.
 unfold isWellFormed in |- *.
 unfold lambdaAbs in |- *.
 simpl in |- *.
 intros.
 apply isWellFormedBindN; auto.
Qed.

Lemma wellFormedUp:forall (l1 :lambda_terms)(i j k:nat),
                   isWellFormedN i l1->
                   isWellFormedN (i+j) (up_lambda l1 j k).
Proof.
  intro l1;elim l1.
  simpl up_lambda in |- *.
  intros; elim (le_lt_dec k n); intro.
  cut (n < i).
  intro; apply wellFLe1; auto with arith.
  apply wellFLe2; auto.
  apply wellFLe with i.
  auto with arith.
  auto.
  simpl in |- *; auto.
  simpl in |- *; auto.
  simpl in |- *.
  intros; elim H1; split; auto.
  simpl in |- *; intros; auto.
  cut (S (i + j) = S i + j).
  intro H1; rewrite H1.
  auto.
  auto with arith.
  simpl in |- *; intros.
  elim H1; split; auto.
  simpl in |- *; intros; auto.
  simpl in |- *; intros; auto.
  simpl in |- *; intros; auto.
  simpl in |- *; intros; auto.
  simpl in |- *; intros;auto.
  simpl in |- *; intros; auto.
Qed.

Lemma wellFormNSub:forall (l1 l2:lambda_terms)(i j n:nat)(st:semType),
                        isWellFormedN i l2->
                        isWellFormedN j l1->
                        isWellFormedN (i+j) (lambdaSubN l1 l2 j n st).
Proof.
 intro l1; elim l1; intros.
 simpl in |- *.
 apply wellFLe1.
 cut (n < j).
 unfold lt in |- *; intro.
 apply le_trans with j.
 auto.
 auto with arith.
 apply wellFLe2; auto.
 simpl in |- *.
 auto.
 simpl in |- *.
 case (eq_nat_dec n n0).
 case (eqDecSem s st).
 unfold lift_lambda in |- *.
 intros; apply wellFormedUp.
 auto.
 simpl in |- *; auto.
 simpl in |- *; auto.
 simpl in |- *.
 simpl in H2; split.
 elim H2; auto.
 elim H2; auto.
 simpl in |- *.
 simpl in H1.
 cut (S (i + j) = i + S j).
 intro H2; rewrite H2.
 auto.
 auto with arith.
 elim H2; simpl in |- *; split; auto.
 simpl in H1; simpl in |- *; auto.
 simpl in H1; simpl in |- *; auto.
 simpl in H1; simpl in |- *; auto.
 simpl in H1; simpl in |- *; auto.
 simpl in H1; simpl in |- *; auto.
 simpl in H1; simpl in |- *; auto.
Qed.

Lemma isWellFormedSubst:forall (l1 l2:lambda_terms)(n:nat)(st:semType),
                         isWellFormed l2->
                         isWellFormed l1->
                         isWellFormed (lambSub l1 l2 n st).
Proof.
 unfold isWellFormed in |- *; unfold lambSub in |- *.
 intros.
 change (isWellFormedN (0 + 0) (lambdaSubN l1 l2 0 n st)) in |- *.
 apply wellFormNSub;auto.
Qed.

(* welltyped and wellformed *)
Lemma wellTypedFormed:forall (l:lambda_terms)(t1:semType)(env:list semType),
                             isWellTyped env l t1 ->
                             isWellFormedN (length env) l.
Proof.
intro l ; elim l; intros.
inversion H.
apply wellFLe1.
eapply nth_error_some_length; eauto.
simpl in |- *; auto.
simpl;auto.
inversion H1;simpl;split;eauto.
inversion H0; simpl.
cut ((S (length env))=(length (s::env))).
intro R; rewrite R;eauto.
simpl;auto.
inversion H1;simpl; split;eauto.
inversion H0; simpl;eauto.
inversion H0; simpl; eauto.
inversion H0;simpl;eauto.
inversion H0;simpl;eauto.
inversion H0;simpl;eauto.
inversion H0;simpl;eauto.
Defined.

(* some auxiliary lemmas about well-typeness *)
Lemma wellTypedBind: forall (l:lambda_terms)(t1:semType)
                     (env:(list semType))(n:nat)(st:semType),
                            isWellTyped env l t1 ->
                           (forall (i:nat)(env':list semType),
                              add_ith_list st env env' i->
                              isWellTyped env' (lambdaBind l i n st) t1).
Proof.
 induction 1; intros; simpl in |- *.
 case (le_lt_dec i n0).
 intro; constructor.
 eapply nth_add1; eauto.
 intro; constructor; eapply nth_add2; eauto.
 constructor.
 auto.
 case (eq_nat_dec n0 n).
 case (eqDecSem ty st).
 intros; subst; constructor.
 eapply nth_add3; eauto.
 intros; constructor.
 intro; constructor.
 econstructor; eauto.
 constructor.
 apply IHisWellTyped.
 constructor; auto.
 constructor; auto.
 econstructor; eauto.
 econstructor; eauto.
 constructor; auto.
 constructor; auto.
 constructor; auto.
 constructor; auto.
Defined.

Lemma wellTypedAbs:forall (l:lambda_terms)(t1:semType)
             (env:list semType)(n:nat)(st:semType),
                       isWellTyped env l t1 ->
                       isWellTyped env (lambdaAbs l n st) (funAppli st t1).
Proof.
intros.
unfold lambdaAbs.
constructor.
eapply wellTypedBind.
eauto.
constructor.
Defined.

Lemma wellTypedAppEnv:forall (l1:lambda_terms)(env1 env2:list semType)(t1:semType),
                       isWellTyped env1 l1 t1 ->
                       isWellTyped (env1++ env2) l1 t1.
Proof.
intro l1; elim l1; intros.
inversion H.
constructor.
apply nth_error_fst_app; auto.
inversion H.
constructor.
auto.
inversion H.
constructor.
inversion H1; econstructor;eauto.
inversion H0; constructor.
change (s::env1++env2) with ((s::env1)++env2).
apply H;auto.
inversion H1; constructor;auto.
inversion H0; econstructor;eauto.
inversion H0; econstructor; eauto.
inversion H0; constructor;auto.
inversion H0; constructor;auto.
inversion H0; constructor;auto.
inversion H0; constructor;auto.
Defined.

Lemma wellTypedSub: forall(l1 l2 :lambda_terms)(env:list semType)
                                (i n:nat)(t1 st:semType),
                               isWellTyped nil l2 st ->
                               isWellTyped env l1 t1 ->
                               isWellTyped env (lambdaSubN l1 l2 i n st) t1.
Proof.
intro l1; elim l1; intros;simpl.
auto.
auto.
case (eq_nat_dec n n0).
case (eqDecSem s st).
intros; subst.
inversion H0.
subst.
unfold lift_lambda in |- *; rewrite lift_wf.
change env with (nil ++ env) in |- *.
apply wellTypedAppEnv; auto.
exact (wellTypedFormed H).
auto.
auto.
inversion H2.
econstructor;eauto.
inversion H1.
constructor;eauto.
inversion H2; constructor;auto.
inversion H1;econstructor;eauto.
inversion H1; econstructor;eauto.
inversion H1; constructor;auto.
inversion H1; constructor;auto.
inversion H1; constructor;auto.
inversion H1; constructor;auto.
Defined.

Lemma wellTypedSubst: forall(l1 l2 :lambda_terms)(env:list semType)
                                (n:nat)(t1 st:semType),
                               isWellTyped nil l2 st ->
                               isWellTyped env l1 t1 ->
                               isWellTyped env (lambSub l1 l2 n st) t1.
Proof.
unfold lambSub in |- *.
intros; apply wellTypedSub; auto.
Defined.

End lambdaX.
End allSem.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Complex_MP.

Coq < Goal forall k b n r:Prop, (((k \/ b) -> (n /\ r)) /\ (k \/ b)) -> (n /\ r).
1 subgoal

  ============================
   forall k b n r : Prop, (k \/ b -> n /\ r) /\ (k \/ b) -> n /\ r

Unnamed_thm < intros.
1 subgoal

  k : Prop
  b : Prop
  n : Prop
  r : Prop
  H : (k \/ b -> n /\ r) /\ (k \/ b)
  ============================
   n /\ r

Unnamed_thm < elim H.
1 subgoal

  k : Prop
  b : Prop
  n : Prop
  r : Prop
  H : (k \/ b -> n /\ r) /\ (k \/ b)
  ============================
   (k \/ b -> n /\ r) -> k \/ b -> n /\ r

Unnamed_thm < intro.
1 subgoal

  k : Prop
  b : Prop
  n : Prop
  r : Prop
  H : (k \/ b -> n /\ r) /\ (k \/ b)
  H0 : k \/ b -> n /\ r
  ============================
   k \/ b -> n /\ r

Unnamed_thm < intro.
1 subgoal

  k : Prop
  b : Prop
  n : Prop
  r : Prop
  H : (k \/ b -> n /\ r) /\ (k \/ b)
  H0 : k \/ b -> n /\ r
  H1 : k \/ b
  ============================
   n /\ r

Unnamed_thm < apply H0.
1 subgoal

  k : Prop
  b : Prop
  n : Prop
  r : Prop
  H : (k \/ b -> n /\ r) /\ (k \/ b)
  H0 : k \/ b -> n /\ r
  H1 : k \/ b
  ============================
   k \/ b

Unnamed_thm < exact H1.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
apply H0.
exact H1.

Unnamed_thm is defined

Coq <

*)

Section Complex_MP.
Goal forall k b n r:Prop, (((k \/ b) -> (n /\ r)) /\ (k \/ b)) -> (n /\ r).
intros.
elim H.
intro.
intro.
apply H0.
exact H1.
Qed.


(************************************************************
* Lambda-calculus,                                          *
* Pretty-big-step semantics                                 *
*************************************************************)

Set Implicit Arguments.
Require Export Lambda_Syntax.

Implicit Types v : val.
Implicit Types t : trm.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Semantics *)

(** Grammar of outcomes *)

Inductive out :=
  | out_ret : val -> out
  | out_div : out.

Coercion out_ret : val >-> out.
Implicit Types o : out.

(** Grammar of extended terms *)

Inductive ext : Type :=
  | ext_trm : trm -> ext
  | ext_app_1 : out -> trm -> ext
  | ext_app_2 : val -> out -> ext.

Coercion ext_trm : trm >-> ext.
Implicit Types e : ext.

(** Evaluation judgment *)

Inductive red : ext -> out -> Prop :=
  | red_val : forall v,
      red v v
  | red_abs : forall x t,
      red (trm_abs x t) (val_clo x t)
  | red_app : forall o1 t1 t2 o2,
      red t1 o1 ->
      red (ext_app_1 o1 t2) o2 ->
      red (trm_app t1 t2) o2
  | red_app_1_abort : forall t2,
      red (ext_app_1 out_div t2) out_div
  | red_app_1 : forall o2 v1 t2 o,
      red t2 o2 ->
      red (ext_app_2 v1 o2) o ->
      red (ext_app_1 v1 t2) o
  | red_app_2_abort : forall v1,
      red (ext_app_2 v1 out_div) out_div
  | red_app_2 : forall x t3 v2 o,
      red (subst x v2 t3) o ->
      red (ext_app_2 (val_clo x t3) v2) o.

(** Co-evaluation judgment: copy-paste of the above
    definition, where [red] is replaced with [cored]
    and where [Inductive] becomes [CoInductive]. *)

CoInductive cored : ext -> out -> Prop :=
  | cored_val : forall v,
      cored v v
  | cored_abs : forall x t,
      cored (trm_abs x t) (val_clo x t)
  | cored_app : forall o1 t1 t2 o2,
      cored t1 o1 ->
      cored (ext_app_1 o1 t2) o2 ->
      cored (trm_app t1 t2) o2
  | cored_app_1_abort : forall t2,
      cored (ext_app_1 out_div t2) out_div
  | cored_app_1 : forall o2 v1 t2 o,
      cored t2 o2 ->
      cored (ext_app_2 v1 o2) o ->
      cored (ext_app_1 v1 t2) o
  | cored_app_2_abort : forall v1,
      cored (ext_app_2 v1 out_div) out_div
  | cored_app_2 : forall x t3 v2 o,
      cored (subst x v2 t3) o ->
      cored (ext_app_2 (val_clo x t3) v2) o.

Definition diverge e := cored e out_div.

(*==========================================================*)
(* * Proofs *)

(************************************************************)
(* ** Basic properties of the semantics *)

Hint Constructors red cored.
Hint Extern 1 (_ <> _) => congruence.

(** Proof that [cored] contains [red] *)

Theorem red_cored : forall e o,
  red e o -> cored e o.
Proof. introv H. induction* H. Qed.

(** Proof that [red e out_div] is not derivable *)

Definition ext_not_diverge e :=
  let n o := o <> out_div in
  match e with
  | ext_trm _ => True
  | ext_app_1 o1 t2 => n o1
  | ext_app_2 v1 o2 => n o2
  end.

Hint Unfold ext_not_diverge.

Lemma red_not_div_ind : forall e o,
  red e o -> ext_not_diverge e -> o <> out_div.
Proof. introv H. induction* H. Qed.

Lemma red_not_div : forall t o,
  red (ext_trm t) o -> o <> out_div.
Proof. introv H. apply* red_not_div_ind. Qed.

(** Proof that [cored] implies [red] or [diverge] *)

Ltac testi H :=
  match type of H with cored ?e ?o => tests: (red e o) end.

Lemma cored_not_red_diverge : forall e o,
  cored e o -> ~ red e o -> diverge e.
Proof.
  unfold diverge. cofix IH. introv C R.
  inverts C; try solve [ false* R ].
  testi H.
    constructors*.
    constructors~. applys* IH.
  testi H.
    constructors*.
    constructors~. apply* IH.
  constructors. applys* IH.
Qed.

Corollary cored_to_diverge_or_red : forall e o,
  cored e o -> diverge e \/ red e o.
Proof.
  introv C. apply or_classic_l. intros.
  applys* cored_not_red_diverge.
Qed.

(************************************************************)
(* ** Determinacy *)

(** Definition of deterministic *)

Definition deterministic :=
  forall e o1 o2, red e o1 -> cored e o2 -> o1 = o2.

(** Proof that the language is deterministic *)

Lemma red_cored_deterministic : deterministic.
Proof.
  introv R C. gen o2. induction R; intros;
   inverts C; auto; try solve [ false; auto ].
  rewrite~ <- IHR2. erewrite* IHR1.
  rewrite~ <- IHR2. erewrite* IHR1.
Qed.

(** Corollary: [red] is deterministic *)

Corollary red_deterministic :
  forall e o1 o2, red e o1 -> red e o2 -> o1 = o2.
Proof.
  introv R1 R2. hint red_cored.
  applys* red_cored_deterministic.
Qed.

(** Corollary: termination and divergence are exclusive
    for terms *)

Corollary red_not_diverge_trm :
  forall t o, red t o -> diverge t -> False.
Proof.
  introv R1 R2. forwards M: red_cored_deterministic R1 R2.
  applys* red_not_div M.
Qed.

(************************************************************)
(* ** Induction principle on the height of a derivation *)

(** Ideally, would be automatically generated by Coq *)

Section RedInd.

(** Copy-paste of the definition of [red], plus a depth counter *)

Inductive redh : nat -> ext -> out -> Prop :=
  | redh_val : forall n v,
      redh (S n) v v
  | redh_abs : forall n x t,
      redh (S n) (trm_abs x t) (val_clo x t)
  | redh_app : forall n o1 t1 t2 o2,
      redh n t1 o1 ->
      redh n (ext_app_1 o1 t2) o2 ->
      redh (S n) (trm_app t1 t2) o2
  | redh_app_1_abort : forall n t2,
      redh (S n) (ext_app_1 out_div t2) out_div
  | redh_app_1 : forall n o2 v1 t2 o,
      redh n t2 o2 ->
      redh n (ext_app_2 v1 o2) o ->
      redh (S n) (ext_app_1 v1 t2) o
  | redh_app_2_abort : forall n v1,
      redh (S n) (ext_app_2 v1 out_div) out_div
  | redh_app_2 : forall n x t3 v2 o,
      redh n (subst x v2 t3) o ->
      redh (S n) (ext_app_2 (val_clo x t3) v2) o.

Hint Constructors redh.
Hint Extern 1 (_ < _) => math.

Lemma redh_lt : forall n n' e o,
  redh n e o -> n < n' -> redh n' e o.
Proof.
  introv H. gen n'. induction H; introv L;
   (destruct n' as [|n']; [ false; math | autos* ]).
Qed.

Lemma red_redh : forall e o,
  red e o -> exists n, redh n e o.
Proof.
  hint redh_lt. introv H. induction H; try induct_height.
Qed.

Lemma redh_red : forall n e o,
  redh n e o -> red e o.
Proof. introv H. induction* H. Qed.

End RedInd.

(************************************************************)
(* ** Equivalence between with big-step *)

Require Import Lambda_Big.
Hint Constructors bigred.
Hint Extern 1 (_ < _) => math.

(** [bigred] to [red] *)

Lemma bigred_red : forall t v,
  bigred t v -> red t v.
Proof. introv H. induction H; simpls*. Qed.

(** [red] to [bigred] *)

Lemma red_bigred : forall t v,
  red t v -> bigred t v.
Proof.
  introv R. forwards (n&R'): red_redh (rm R).
  gen v t. induction n using peano_induction.
  asserts IH: (forall m t v, redh m t v -> m < n -> bigred t v).
    intros. apply* H. clear H.
  introv R. inverts R as; autos*.
  introv R1 R2. inverts R2 as R2 R3. inverts* R3.
Qed.

(** [bigdiv] to [diverge] *)

Lemma bigdiv_diverge : forall t,
  bigdiv t -> diverge t.
Proof.
  asserts K: (forall t b, bigred t b -> cored t b).
   intros. apply red_cored. apply~ bigred_red.
  unfold diverge. cofix IH.
  introv H. inverts H; try solve [constructors*].
Qed.

(** [diverge] to [bigdiv] *)

Lemma diverge_bigdiv : forall t,
  diverge t -> bigdiv t.
Proof.
  hint red_bigred. cofix IH. introv R. inverts R as.
  introv R1 R2. destruct~ (cored_to_diverge_or_red R1).
    apply* bigdiv_app_1.
    inverts R2 as.
      intros. apply~ bigdiv_app_1.
      introv R2 R3. destruct~ (cored_to_diverge_or_red R2).
        apply* bigdiv_app_2.
        inverts R3 as.
          intros. apply* bigdiv_app_2.
          introv R3. apply* bigdiv_app_3.
Qed.


From stdpp Require Import prelude.
From Coq Require Import ClassicalEpsilon.
From sets Require Import Ensemble.
From ARL.Lib Require Import Traces.

Class TransitionSystem (idomain : Type) := transition : relation idomain.

Section sec_transition_system.

Context `{TransitionSystem}.

Definition transition_image (a : idomain) : Ensemble idomain := transition a.
Definition transition_image_functor (A : Ensemble idomain) : Ensemble idomain := filtered_union A transition_image.

Definition reducible (a : idomain) : Prop := exists b, transition a b.
Definition irreducible (a : idomain) : Prop := ~ reducible a.

Lemma irreducible_transition_image a : irreducible a <-> transition_image a ≡ ∅.
Proof. by unfold irreducible, reducible; set_solver. Qed.

Lemma irreducible_iff_no_transition a :
  irreducible a <-> forall b, ~ transition a b.
Proof. by firstorder. Qed.

Lemma reducible_transition_image a : reducible a <-> ∅ ⊂ transition_image a.
Proof.
  destruct (classic (reducible a)) as [| Ha];
    [by split; [unfold reducible, transition_image; set_solver |] |].
  apply irreducible_transition_image in Ha as Hempty.
  setoid_rewrite irreducible_iff_no_transition in Ha.
  unfold transition_image in *.
  unfold reducible.
  by set_solver.
Qed.

Lemma transition_image_subseteq a A :
  transition_image a ⊆ A
    <->
  forall b, transition a b -> b ∈ A.
Proof. firstorder. Qed.

Inductive TransitionSequence : list idomain -> Prop :=
| ts_singleton : forall a b, transition a b -> TransitionSequence [a; b]
| ts_more : forall a b l, transition a b -> TransitionSequence (b :: l) ->
    TransitionSequence (a :: b :: l).

Definition transition_sequence : list idomain -> Prop :=
  ForAllConsecutivePairsList transition.

Lemma transition_sequence_iff a b trs :
  TransitionSequence (a :: b :: trs)
    <->
  transition_sequence (a :: b :: trs).
Proof.
  remember (a :: b :: trs) as abtrs.
  revert a b trs Heqabtrs.
  induction abtrs; [by inversion 1 |].
  inversion 1; subst.
  split; inversion 1; subst.
  - do 2 (constructor; [done |]).
    by constructor.
  - constructor; [done |].
    destruct trs; [by constructor; [| constructor] |].
    by eapply IHabtrs.
  - destruct trs; [by constructor 1 |].
    constructor; [done |].
    by eapply IHabtrs.
Qed.

Record CompleteTransitionChain (tr : trace idomain) : Prop :=
{
  ctc_transition_chain : ForAllConsecutivePairs transition tr;
  ctc_complete : forall a, finalT tr a -> irreducible a
}.

Definition complete_transition_chain : trace idomain -> Prop :=
  ForAllSuffixes
    (fun tr => match tr with
    | Tnil a => irreducible a
    | Tcons a tr => transition a (hd tr)
    end).

Lemma complete_transition_chain_iff tr :
  CompleteTransitionChain tr
    <->
  complete_transition_chain tr.
Proof.
  split; [| intro Htr; split].
  - intros [Hchain Hcomplete].
    revert tr Hchain Hcomplete.
    cofix Hind; intros [] ? ?;
      [by constructor; apply Hcomplete; constructor |].
    inversion Hchain; subst.
    constructor; [done |].
    apply Hind; [done |].
    by intros; apply Hcomplete; constructor.
  - revert tr Htr.
    cofix Hind; intros [] ?; [by constructor |].
    inversion Htr; subst.
    constructor; [done |].
    by apply Hind.
  - intros a Ha; revert Htr.
    by induction Ha; inversion 1; subst; [| apply IHHa].
Qed.

Lemma complete_transition_chain_nil : forall a, irreducible a -> complete_transition_chain (Tnil a).
Proof. by intros; apply Forall_nil. Qed.

Lemma complete_transition_chain_delay : forall a tr,
  transition a (hd tr) -> complete_transition_chain tr -> complete_transition_chain (Tcons a tr).
Proof. by intros; eapply Forall_delay. Qed.

Lemma complete_transition_chain_nth_tl_keep_nil tr n : complete_transition_chain tr -> complete_transition_chain (nth_tl_keep_nil tr n).
Proof. by apply ForAllSuffixes_drop_n. Qed.

Lemma complete_transition_chain_prefix tr :
  complete_transition_chain tr ->
  forall n, transition_sequence (trace_prefix tr n).
Proof.
  intros Hchain.
  by apply forall_consecutive_pairs_trace_prefix, ctc_transition_chain,
    complete_transition_chain_iff.
Qed.

Section sec_iterated_choice.

Context
  (A : Ensemble idomain)
  (choose: {a : idomain | ¬ irreducible a} → idomain).

CoFixpoint iterated_choice
  (a : idomain)
  : trace idomain
  :=
  match (excluded_middle_informative (irreducible a)) with
  | left _ => Tnil a
  | right Hnot_irreducible =>
    Tcons a (iterated_choice (choose (exist _ a Hnot_irreducible)))
  end.

Lemma iterated_choice_unfold
  (a : idomain)
  : iterated_choice a
    =
    match (excluded_middle_informative (irreducible a)) with
    | left _ => Tnil a
    | right Hnot_irreducible =>
      Tcons a (iterated_choice (choose (exist _ a Hnot_irreducible)))
    end.
Proof. by apply trace_eq_hd_tl; done. Qed.

Lemma iterated_choice_hd (a : idomain) :
  hd (iterated_choice a) = a.
Proof.
  rewrite iterated_choice_unfold.
  by destruct (excluded_middle_informative (irreducible a)).
Qed.

End sec_iterated_choice.

Lemma complete_transition_chain_from_head :
  forall a, exists tr : trace idomain, hd tr = a /\ complete_transition_chain tr.
Proof.
  assert (Hall_ex :
   forall x : {a : idomain | ~ irreducible a},
                    exists a' : idomain, transition (` x) a').
  {
    intros (a0 & Hnot_irreducible0).
    by apply NNPP.
  }
  apply choice in Hall_ex as [choose Hchoose].
  intro a.
  exists (iterated_choice choose a).
  split; [by apply iterated_choice_hd |].
  revert a; cofix Hind; intro a.
  rewrite iterated_choice_unfold.
  destruct (excluded_middle_informative (irreducible a));
    [by apply Forall_nil |].
  apply Forall_delay; [| by apply Hind].
  rewrite iterated_choice_hd.
  by apply (Hchoose (exist _ a n)).
Qed.

Lemma transition_sequence_to_complete_transition_chain :
  forall a ts, transition_sequence (a :: ts) ->
  exists tr, complete_transition_chain tr /\
    trace_prefix tr (S (length ts)) = a :: ts.
Proof.
  intros a ts Hts.
  pose (lst := List.last ts a).
  destruct (complete_transition_chain_from_head lst) as (tr & Heqlst & Htr).
  exists (trace_prepend (removelast (a :: ts)) tr).
  split.
  - apply complete_transition_chain_iff; split.
    + apply forall_consecutive_pairs_trace_prepend;
        [by apply complete_transition_chain_iff | done |].
      by rewrite last_cons.
    + intros final; rewrite <- trace_prepend_finalT.
      by apply complete_transition_chain_iff.
  - remember (a :: ts) as ats; clear Hts; revert a ts lst Heqlst Heqats.
    induction ats; [by inversion 1 |]; intros.
    inversion Heqats; subst; clear Heqats.
    destruct ts; subst lst; [by cbn in Heqlst; subst a0; destruct tr |].
    rewrite last_cons in Heqlst.
    specialize (IHats _ _ Heqlst eq_refl).
    by rewrite <- IHats at 3.
Qed.

Section sec_traces.

End sec_traces.

End sec_transition_system.


Require Import Coq.Lists.List.
Require Import Coq.Program.Program.
Require Import Coq.Logic.Eqdep_dec.
Require Import Cosa.Lib.Extra.

(** Initial segments of ℕ, aka (skeletal) finite types. *)

Fixpoint fin (n:nat) : Type := match n with
  | 0 => Empty_set
  | S n' => option (fin n')
end.

(** Vectors are lists anotated by their size. *)
Definition vector (A:Type) (n:nat) := { l:list A | length l = n }.

(** Because the equality on natural number is decidable, [eq] has uip
    on nat. *)
Lemma nat_eq_uip (n m:nat) : forall (p q:n=m), p = q.
Proof.
  apply UIP_dec.
  { decide equality. }
Qed.

(** Because the equality on natural number is decidable, vector
    equality is just the equality of the underlying list. *)
Lemma vector_eq {A n} (l v:vector A n) : `l = `v -> l = v.
Proof.
  destruct l as [ l ? ]; destruct v as [ v ? ]; simpl.
  intros ->.
  f_equal.
  apply nat_eq_uip.
Qed.

Definition pack_vector {A:Type} (l:list A) : vector A (length l) :=
  exist _ l eq_refl
.

(** A function [fin n -> A] is essentially a list of [A] *)
Fixpoint listify {A n} : (fin n -> A) -> list A :=
  match n as n return (fin n -> A) -> list A with
  | 0 => fun _ => nil
  | S n' => fun f => f None :: listify (fun (i:fin n') => f (Some i))
  end
.

Lemma listify_length {A n} (f:fin n -> A) : length (listify f) = n.
Proof.
  induction n as [ | n h ].
  - easy.
  - simpl.
    f_equal.
    auto.
Qed.

Program Definition listifyv {A n} (f:fin n -> A) : vector A n :=
  listify f
.
Next Obligation.
  apply listify_length.
Qed.

Lemma listifyv_correct {A n} (f:fin n -> A) : proj1_sig (listifyv f) = listify f.
Proof.
  reflexivity.
Qed.

Definition elim_nil_s {A B n} (p:length (@nil A) = S n) : B.
Proof.
  discriminate p.
Defined.

Definition strip_s {n m} (p:S n = S m) : n=m :=
  match p
        in (_ = y)
        return (n = match y with
                    | 0 => n
                    | S n0 => n0
                    end)
  with
  | eq_refl => eq_refl
  end
.

Fixpoint accessv {A n} : vector A n -> fin n -> A :=
  match n as n return vector A n -> fin n -> A with
  | 0 => fun _ (i:Empty_set) => match i with end
  | S n' => fun v =>
              let '(exist l e) := v in
              match l
                    as l
                    return length l = S n' -> fin (S n') -> A
              with
              | a::l' => fun (e:length (a::l') = S n') i =>
                match i return A with
                | None => a
                | Some i' => accessv (exist _ l' (strip_s e)) i'
                end
              | nil => elim_nil_s
              end e
  end
.

Definition access {A} (l:list A) (i:fin (length l)) : A :=
  accessv (pack_vector l) i
.

Lemma accessv_correct {A} (l:list A) : forall i, accessv (pack_vector l) i = access l i.
Proof. easy. Qed.

Lemma listify_access {A} (l:list A) : listify (access l) = l.
Proof.
  induction l.
  - easy.
  - simpl.
    f_equal.
    assumption.
Qed.

Lemma listifyv_accessv {A n} (l:vector A n) : listifyv (accessv l) = l.
Proof.
  destruct l as [ l <- ].
  apply vector_eq.
  simpl.
  refine (listify_access _).
Qed.

(** [forall i, access (listify f) i = f i] is basically true, but does
    not typecheck. We only have the vectorised version. *)
Lemma accessv_listifyv {A n} (f:fin n -> A) : forall i, accessv (listifyv f) i = f i.
Proof.
  induction n as [ | n h ].
  - (* n=0 *)
    intros [].
  - (* n=S n *)
    unfold listifyv; simpl.
    intros [ i' | ].
    + (* i=Some i' *)
      unfold listifyv in h.
      specialize (h (fun i=>f (Some i)) i').
      match goal with
      | H:appcontext[exist _ _ ?e₁] |-appcontext[exist _ _ ?e₂] => assert (e₁=e₂) as ->
      end.
      { apply nat_eq_uip. }
      apply h.
    + (* i=None *)
      reflexivity.
Qed.

(** The type [Collectible] is a caracterisation of finite types (see
    http://winterkoninkje.dreamwidth.org/81209.html ). In Coq, it is
    not probably weaker to having a list of all the elements which is
    also true of [fin n].

   We use collectibility in [Cosa.Interaction.Rule]. *)

Section Collection.

  Context {F:Type->Type} (a:Applicative F).

  Definition Collectible A := forall B, (forall x:A, F (B x)) -> F (forall x:A,B x).

  Definition patch {A B} (n:B None) (s:forall x:A, B (Some x)) : forall x:option A, B x :=
    fun x => match x with None => n | Some x => s x end
  .

  Fixpoint collectn {n} : Collectible (fin n) :=
    match n as n return Collectible (fin n) with
    | 0 => fun _ _ => pure a (fun i:Empty_set => match i with end)
    | S _ => fun B f =>
               let n := f None in
               let s := collectn _ (fun i => f (Some i)) in
               map2 a patch n s
    end
  .

End Collection.
Arguments Collectible F A : clear implicits.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** Key constructor: List.  *)

Set Implicit Arguments.

Require Import OrderedType.
Require Import hpattern vgtac.
Require Import VocabA DLat.

Module ListKey (A : KEY) <: KEY.

Module F := OrderedTypeFacts (A).

Inductive t' :=
| nil
| cons (hd_x : A.t) (tl_x : t').
Definition t := t'.

Fixpoint app x y :=
  match x with
    | nil => y
    | cons hd_x tl_x => cons hd_x (app tl_x y)
  end.

Inductive eq' : t -> t -> Prop :=
| eq_nil : eq' nil nil
| eq_cons : forall (hd1 hd2 : A.t) (Hhd: A.eq hd1 hd2)
                   (tl1 tl2 : t) (Htl: eq' tl1 tl2),
              eq' (cons hd1 tl1) (cons hd2 tl2).

Definition eq : t -> t -> Prop := eq'.

Inductive lt' : t -> t -> Prop :=
| lt_nil : forall (hd : A.t) (tl : t), lt' nil (cons hd tl)
| lt_cons1 : forall (hd1 hd2 : A.t) (Hhd : A.eq hd1 hd2)
                    (tl1 tl2 : t) (Htl : lt' tl1 tl2),
               lt' (cons hd1 tl1) (cons hd2 tl2)
| lt_cons2 : forall (hd1 hd2 : A.t) (Hhd : A.lt hd1 hd2) (tl1 tl2 : t),
               lt' (cons hd1 tl1) (cons hd2 tl2).

Definition lt : t -> t -> Prop := lt'.

Lemma eq_refl : forall x : t, eq x x.
Proof. induction x; econs; by auto using A.eq_refl. Qed.

Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof. induction 1; econs; by eauto using A.eq_sym. Qed.

Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof.
i; depgen z; induction H; [inversion 1; by econs|].
inversion 1; subst; econs; [by eauto using A.eq_trans|].
by apply IHeq'.
Qed.

Definition zb_eq : zb_equiv eq :=
  {| zb_equiv_refl := eq_refl
   ; zb_equiv_sym := eq_sym
   ; zb_equiv_trans := eq_trans |}.

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.
i; depgen z; induction H; [inversion 1; by econs| |].
+ inversion 1; subst.
  - apply lt_cons1; [eauto using A.eq_trans|]; by apply IHlt'.
  - apply lt_cons2; by eauto using F.lt_eq.
+ inversion 1; subst.
  - apply lt_cons2; by eauto using F.eq_lt.
  - apply lt_cons2; by eauto using A.lt_trans.
Qed.

Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof.
induction 1; [by inversion 1|by inversion 1|].
inversion 1; subst; eapply A.lt_not_eq; eauto.
Qed.

Fixpoint compare (x y : t) : Compare lt eq x y.
refine  match x, y with
          | nil, nil => EQ eq_nil
          | nil, cons hd_x tl_x => LT (lt_nil hd_x tl_x)
          | cons hd_x tl_x, nil => GT (lt_nil hd_x tl_x)
          | cons hd1 tl1, cons hd2 tl2 =>
            match A.compare hd1 hd2 with
              | LT l => LT (lt_cons2 l tl1 tl2)
              | EQ _ =>
                match compare tl1 tl2 with
                  | LT _ => LT _
                  | EQ _ => EQ _
                  | GT _ => GT _
                end
              | GT l => GT (lt_cons2 l tl2 tl1)
            end
        end.
+ apply lt_cons1; done.
+ apply eq_cons; done.
+ apply lt_cons1; [by apply A.eq_sym|done].
Defined.

Fixpoint eq_dec (x y : t) : {eq x y} + {~ eq x y}.
refine
  ((if physical_eq x y as c return
      physical_eq x y = c -> {eq x y} + {~ eq x y} then fun Hc => left _
   else fun _ =>
          match x, y with
            | nil, nil => left eq_nil
            | cons hd1 tl1, cons hd2 tl2 =>
              match A.eq_dec hd1 hd2 with
                | left _ =>
                  match eq_dec tl1 tl2 with
                    | left _ => left _
                    | right _ => right _
                  end
                | right _ => right _
              end
            | _, _ => right _
          end) Logic.eq_refl); try (by inversion 1).
+ apply physical_eq_prop in Hc; subst; by apply eq_refl.
+ econs; done.
Qed.
Definition eqb x y := if eq_dec x y then true else false.

End ListKey.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import liblayers.logic.Structures.

(** * Categories of abstract data and simulation relations *)

(** ** Reflexive graphs *)

(** A reflexive graph is given by a type of objects, types of arrows
  between any two vertices, and an identity edge at each vertex. *)

Class ReflexiveGraphOps (V: Type) (E: V -> V -> Type): Type :=
  {
    cat_id v :> Id (E v v)
  }.

Class ReflexiveGraph V E `{VEops: ReflexiveGraphOps V E}: Prop.

(** ** Categories *)

(** A category additionally provides a composition operator for arrows
  with matching endpoints, with unsurprising properties. *)

Class CategoryOps (V: Type) (E: V -> V -> Type): Type :=
  {
    cat_rg_ops :> ReflexiveGraphOps V E;
    cat_compose v1 v2 v3 :> Compose (E v1 v2) (E v2 v3) (E v1 v3)
  }.

Class Category V E `{VEops: CategoryOps V E}: Prop :=
  {
    cat_compose_id_left {v1 v2: V}:
      forall (e: E v1 v2),
        id ∘ e = e;
    cat_compose_id_right {v1 v2: V}:
      forall (e: E v1 v2),
        e ∘ id = e;
    cat_compose_assoc {v1 v2 v3 v4: V}:
      forall (e12: E v1 v2) (e23: E v2 v3) (e34: E v3 v4),
        e34 ∘ (e23 ∘ e12) = (e34 ∘ e23) ∘ e12
  }.

(** A category is a special case of a reflexive graph. *)
Global Instance cat_rg V E `{Category V E}: ReflexiveGraph V E.

(** * Associated concrete simulation relations *)

(** We map the objects and arrows onto types and relations in some
  kinds of structure-preserving ways. *)

(** ** Simulation relations indexed by reflexive graphs *)

(** For reflexive graphs, this means that the relations associated to
  [id] arrows are preorders, and some kind of identities for relation
  composition. *)

Class ReflexiveGraphSim V E T
  `{rg_ops: ReflexiveGraphOps V E}
  `{rg_sim: Sim V E T}: Prop :=
  {
    rg_sim_id (v: V) :>
      PreOrder (simRR v v id);
    rg_sim_compose (v1 v2: V) (e: E v1 v2) :>
      Proper (sim id --> sim id ++> impl) (sim e)
  }.

(** We also write [sim id] as [(≤)]. *)

Global Instance rg_sim_le_op {V E} T `{ReflexiveGraphOps V E} `{Sim V E T} v:
  Le (T v) :=
  {
    le := sim id
  }.

(* XXX: is it still necessary? *)
Global Instance rg_sim_equiv V E T `{ReflexiveGraphSim V E T}:
  forall (v1 v2: V) (e: E v1 v2),
    Proper ((≡) ==> (≡) ==> impl) (simRR v1 v2 e).
Proof.
  solve_monotonic; firstorder.
Qed.

(** ** Simulation relations indexed by categories *)

Class CategorySim V E T `{cat_ops: CategoryOps V E} `{cat_sim: Sim V E T} :=
  {
    cat_sim_refl v :> @Reflexive (T v) (sim id);
    cat_sim_trans {v1 v2 v3} {e12 e23} {t1: T v1} (t2: T v2) {t3: T v3}:
      sim e12 t1 t2 -> sim e23 t2 t3 -> sim (e23 ∘ e12) t1 t3
  }.

(* XXX: sort out, can generalize to [reflexivity]? *)
Hint Resolve (cat_sim_refl: forall v x, sim id x x) : liblayers.
Hint Immediate cat_sim_trans : liblayers.

Ltac sim_trans_apply σ2 :=
  lazymatch goal with
    | |- simRR (T := ?T) _ _ (?R23 ∘ ?R12) ?σ1 ?σ3 =>
      apply (cat_sim_trans (T := T) σ2)
  end.

Ltac sim_transitivity σ2 :=
  sim_trans_apply σ2 ||
  (setoid_rewrite <- cat_compose_id_right; sim_trans_apply σ2) ||
  (setoid_rewrite <- cat_compose_id_left; sim_trans_apply σ2).

(** Typeclass-friendly version of [cat_sim_trans] for [id]. *)

Global Instance cat_sim_trans_instance `(CategorySim):
  Category V E ->
  forall D, @Transitive (T D) (sim id).
Proof.
  intros HVE D x y z Hxy Hyz.
  sim_transitivity y;
  eassumption.
Qed.

(** Given a [CategorySim] we can derive the corresponding [QuiverSim]
  on the category's underlying quiver. *)

Global Instance catsim_quivsim_prf V E T `{CategorySim V E T} `{!Category V E}:
  ReflexiveGraphSim V E T.
Proof.
  split.
  * intros v; split.
    + apply cat_sim_refl.
    + intros x1 x2 x3 H12 H23.
      simpl.
      sim_transitivity x2; assumption.
  * intros v1 v2 e x1 x2 Hx y1 y2 Hy H1.
    sim_transitivity x1; try assumption.
    sim_transitivity y1; try assumption.
Qed.

(** * Free reflexive graph  *)

(** We can construct the free reflexive graph on a quiver by adjoining
  an identity arrow at every object. *)

(** ** Definition *)

Inductive freerg {V: Type} (E: V -> V -> Type) (v1: V): V -> Type :=
  | freerg_id: freerg E v1 v1
  | freerg_inj (v2: V) (e: E v1 v2): freerg E v1 v2.

Global Instance freerg_ops V E: ReflexiveGraphOps V (freerg E) :=
  {
    cat_id v := {| id := freerg_id E v |}
  }.

Global Instance freerg_prf V E: ReflexiveGraph V (freerg E).

(** ** Building simulation relations *)

Section FREERG_SIM.
  Context {V E T} (R: forall v, rel (T v) (T v)) (RR: @sim_relation V E T).

  Definition freerg_rel (v1 v2: V) (fe: freerg E v1 v2): rel (T v1) (T v2) :=
    match fe with
      | freerg_id => R v1
      | freerg_inj v2 e => RR v1 v2 e
    end.

  Local Instance freerg_sim_op: Sim (freerg E) T :=
    {
      simRR := freerg_rel
    }.

  Local Instance freerg_sim_prf:
    (forall v1 v2 (e: E v1 v2), Proper ((≤) --> (≤) ++> impl) (RR v1 v2 e)) ->
    (forall v, @PreOrder (T v) (R v)) ->
    ReflexiveGraphSim V (freerg E) T.
  Proof.
    intros Hle Hsim.
    split.
    * simpl.
      typeclasses eauto.
    * intros v1 v2 e.
      destruct e as [ | v2 e]; simpl.
      + typeclasses eauto.
      + typeclasses eauto.
  Qed.
End FREERG_SIM.


(* Evaluation Context Definitions *)

Require Import lang_spec.

Inductive ctx_f : Type :=
| hole
| ecf_left (l : ctx_f) (r : expr)
| ecf_right (v : val) (r : ctx_f)
.

Inductive ctx_e : Type :=
| ece_cons (v : var) (F : ctx_f)
.

Inductive ctx_ff : Type :=
| apply_to_val (F : ctx_f) (v : val)
| exch_with_val (F : ctx_f) (v : val)
.

Inductive ctx_ef : Type :=
| f_ece_cons (x : var) (FF : ctx_ff)
.

(* Functions for substituting into the holes in Evaluation Contexts *)

Fixpoint SubExprInF (hole_item : expr) (F : ctx_f) : expr :=
  match F with
  | hole => hole_item
  | ecf_left F' r => app (SubExprInF hole_item F') r
  | ecf_right v F' => app v (SubExprInF hole_item F')
  end.

Fixpoint SubFInF (hole_item : ctx_f) (F : ctx_f) : ctx_f :=
  match F with
  | hole => hole_item
  | ecf_left F' r => ecf_left (SubFInF hole_item F') r
  | ecf_right v F' => ecf_right v (SubFInF hole_item F')
  end.

Fixpoint SubInE (hole_item : expr) (E : ctx_e) : config :=
  match E with
  | ece_cons v F => (v <- (SubExprInF hole_item F))
  end.

(* Coercions so that the substitution functions can be re-used *)

Fixpoint coerce_FF_to_F (FF : ctx_ff) : ctx_f :=
  match FF with
  | apply_to_val F v => SubFInF (ecf_left hole v) F
  | exch_with_val F v => SubFInF (ecf_left (ecf_right (value_c exch) hole) v)
                                         F
  end.
Coercion coerce_FF_to_F : ctx_ff >-> ctx_f.

Definition coerce_fe_to_e (ef : ctx_ef) : ctx_e :=
  match ef with
  | f_ece_cons x FF => ece_cons x FF
  end.
Coercion coerce_fe_to_e : ctx_ef >-> ctx_e.


(** * SfLib: Software Foundations Library *)
(* Version of 4/21/2010 *)

(** Here we collect together several useful definitions and theorems
    from Basics.v, List.v, Poly.v, Ind.v, and Logic.v that are not
    already in the Coq standard library.  From now on we can [Import]
    or [Export] this file, instead of cluttering our environment with
    all the examples and false starts in those files. *)

(** * From the Coq standard library *)

Require Omega.   (* needed for using the [omega] tactic *)
Require Export Bool.
Require Export List.
Require Export Arith.
Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

(** * From Basics.v *)

Definition admit {T: Type} : T.  Admitted.

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Ltac Case name := Case_aux Case name.
Ltac SCase name := Case_aux SCase name.
Ltac SSCase name := Case_aux SSCase name.
Ltac SSSCase name := Case_aux SSSCase name.
Ltac SSSSCase name := Case_aux SSSSCase name.
Ltac SSSSSCase name := Case_aux SSSSSCase name.
Ltac SSSSSSCase name := Case_aux SSSSSSCase name.
Ltac SSSSSSSCase name := Case_aux SSSSSSSCase name.

Fixpoint ble_nat (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => ble_nat n' m'
      end
  end.

Theorem andb_true_elim1 : forall b c,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H. reflexivity.  Qed.

Theorem andb_true_elim2 : forall b c,
  andb b c = true -> c = true.
Proof.
(* An exercise in Basics.v *)
Admitted.

(* From Poly.v *)

Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

(** * From Props.v *)

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

(** * From Logic.v *)

Theorem andb_true : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      apply conj. reflexivity. reflexivity.
      inversion H.
    inversion H.  Qed.

Theorem not_eq_beq_false : forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra.  Qed.

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_true : forall n m,
  ble_nat n m = true -> n <= m.
(* An exercise in Logic.v *)
Admitted.

Theorem ble_nat_false : forall n m,
  ble_nat n m = false -> ~(n <= m).
(* An exercise in Logic.v *)
Admitted.

Definition relation (X:Type) := X -> X -> Prop.

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Inductive next_nat (n:nat) : nat -> Prop :=
  | nn : next_nat n (S n).

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Inductive empty_relation : nat -> nat -> Prop := .

Inductive refl_step_closure (X:Type) (R: relation X)
                            : X -> X -> Prop :=
  | rsc_refl  : forall (x : X),
                 refl_step_closure X R x x
  | rsc_step : forall (x y z : X),
                    R x y ->
                    refl_step_closure X R y z ->
                    refl_step_closure X R x z.
Implicit Arguments refl_step_closure [X].

Tactic Notation "rsc_cases" tactic(first) tactic(c) :=
  first;
  [ c "rsc_refl" | c "rsc_step" ].

Theorem rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> refl_step_closure R x y.
Proof.
  intros X R x y r.
  apply rsc_step with y. apply r. apply rsc_refl.   Qed.

Theorem rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      refl_step_closure R x y  ->
      refl_step_closure R y z ->
      refl_step_closure R x z.
Proof.
  (* FILL IN HERE *) Admitted.


Require Export D.

(** **** Exercise: 2 stars (IFB_false)  *)
Theorem IFB_false: forall b c1 c2,
  bequiv b BFalse  ->
  cequiv
    (IFB b THEN c1 ELSE c2 FI)
    c2.
Proof.
  intros. split; intros.
  Case "->". inversion H0; subst.
    SCase "true". unfold bequiv in H. rewrite H in H6. inversion H6.
    SCase "False". assumption.
  Case "<-". apply E_IfFalse. unfold bequiv in H. rewrite H. reflexivity. assumption.
  Qed.