From Hammer Require Import Hammer.

Require Import Bool NAxioms NSub NPow NDiv NParity NLog.

Module Type NBitsProp
(Import A : NAxiomsSig')
(Import B : NSubProp A)
(Import C : NParityProp A B)
(Import D : NPowProp A B C)
(Import E : NDivProp A B)
(Import F : NLog2Prop A B C D).

Include BoolEqualityFacts A.

Ltac order_nz := try apply pow_nonzero; order'.
Hint Rewrite div_0_l mod_0_l div_1_r mod_1_r : nz.

Lemma pow_sub_r : forall a b c, a~=0 -> c<=b -> a^(b-c) == a^b / a^c.
Proof. hammer_hook "NBits" "NBits.NBitsProp.pow_sub_r".
intros a b c Ha H.
apply div_unique with 0.
generalize (pow_nonzero a c Ha) (le_0_l (a^c)); order'.
nzsimpl. now rewrite <- pow_add_r, add_comm, sub_add.
Qed.

Lemma pow_div_l : forall a b c, b~=0 -> a mod b == 0 ->
(a/b)^c == a^c / b^c.
Proof. hammer_hook "NBits" "NBits.NBitsProp.pow_div_l".
intros a b c Hb H.
apply div_unique with 0.
generalize (pow_nonzero b c Hb) (le_0_l (b^c)); order'.
nzsimpl. rewrite <- pow_mul_l. f_equiv. now apply div_exact.
Qed.

Definition b2n (b:bool) := if b then 1 else 0.
Local Coercion b2n : bool >-> t.

Instance b2n_proper : Proper (Logic.eq ==> eq) b2n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.b2n_proper".   solve_proper. Qed.

Lemma exists_div2 a : exists a' (b:bool), a == 2*a' + b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.exists_div2".
elim (Even_or_Odd a); [intros (a',H)| intros (a',H)].
exists a'. exists false. now nzsimpl.
exists a'. exists true. now simpl.
Qed.

Lemma testbit_0_r a (b:bool) : testbit (2*a+b) 0 = b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_0_r".
destruct b; simpl; rewrite ?add_0_r.
apply testbit_odd_0.
apply testbit_even_0.
Qed.

Lemma testbit_succ_r a (b:bool) n :
testbit (2*a+b) (succ n) = testbit a n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_succ_r".
destruct b; simpl; rewrite ?add_0_r.
apply testbit_odd_succ, le_0_l.
apply testbit_even_succ, le_0_l.
Qed.

Lemma testbit_spec' a n : a.[n] == (a / 2^n) mod 2.
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_spec'".
revert a. induct n.
intros a. nzsimpl.
destruct (exists_div2 a) as (a' & b & H). rewrite H at 1.
rewrite testbit_0_r. apply mod_unique with a'; trivial.
destruct b; order'.
intros n IH a.
destruct (exists_div2 a) as (a' & b & H). rewrite H at 1.
rewrite testbit_succ_r, IH. f_equiv.
rewrite pow_succ_r', <- div_div by order_nz. f_equiv.
apply div_unique with b; trivial.
destruct b; order'.
Qed.

Lemma testbit_spec a n :
exists l h, 0<=l<2^n /\ a == l + (a.[n] + 2*h)*2^n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_spec".
exists (a mod 2^n). exists (a / 2^n / 2). split.
split; [apply le_0_l | apply mod_upper_bound; order_nz].
rewrite add_comm, mul_comm, (add_comm a.[n]).
rewrite (div_mod a (2^n)) at 1 by order_nz. do 2 f_equiv.
rewrite testbit_spec'. apply div_mod. order'.
Qed.

Lemma testbit_true : forall a n,
a.[n] = true <-> (a / 2^n) mod 2 == 1.
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_true".
intros a n.
rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'.
Qed.

Lemma testbit_false : forall a n,
a.[n] = false <-> (a / 2^n) mod 2 == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_false".
intros a n.
rewrite <- testbit_spec'; destruct a.[n]; split; simpl; now try order'.
Qed.

Lemma testbit_eqb : forall a n,
a.[n] = eqb ((a / 2^n) mod 2) 1.
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_eqb".
intros a n.
apply eq_true_iff_eq. now rewrite testbit_true, eqb_eq.
Qed.

Lemma b2n_inj : forall (a0 b0:bool), a0 == b0 -> a0 = b0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.b2n_inj".
intros [|] [|]; simpl; trivial; order'.
Qed.

Lemma add_b2n_double_div2 : forall (a0:bool) a, (a0+2*a)/2 == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_b2n_double_div2".
intros a0 a. rewrite mul_comm, div_add by order'.
now rewrite div_small, add_0_l by (destruct a0; order').
Qed.

Lemma add_b2n_double_bit0 : forall (a0:bool) a, (a0+2*a).[0] = a0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_b2n_double_bit0".
intros a0 a. apply b2n_inj.
rewrite testbit_spec'. nzsimpl. rewrite mul_comm, mod_add by order'.
now rewrite mod_small by (destruct a0; order').
Qed.

Lemma b2n_div2 : forall (a0:bool), a0/2 == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.b2n_div2".
intros a0. rewrite <- (add_b2n_double_div2 a0 0). now nzsimpl.
Qed.

Lemma b2n_bit0 : forall (a0:bool), a0.[0] = a0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.b2n_bit0".
intros a0. rewrite <- (add_b2n_double_bit0 a0 0) at 2. now nzsimpl.
Qed.

Lemma testbit_unique : forall a n (a0:bool) l h,
l<2^n -> a == l + (a0 + 2*h)*2^n -> a.[n] = a0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_unique".
intros a n a0 l h Hl EQ.
apply b2n_inj. rewrite testbit_spec' by trivial.
symmetry. apply mod_unique with h. destruct a0; simpl; order'.
symmetry. apply div_unique with l; trivial.
now rewrite add_comm, (add_comm _ a0), mul_comm.
Qed.

Lemma bits_0 : forall n, 0.[n] = false.
Proof. hammer_hook "NBits" "NBits.NBitsProp.bits_0".
intros n. apply testbit_false. nzsimpl; order_nz.
Qed.

Lemma bit0_odd : forall a, a.[0] = odd a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.bit0_odd".
intros. symmetry.
destruct (exists_div2 a) as (a' & b & EQ).
rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2.
destruct b; simpl; apply odd_1 || apply odd_0.
Qed.

Lemma bit0_eqb : forall a, a.[0] = eqb (a mod 2) 1.
Proof. hammer_hook "NBits" "NBits.NBitsProp.bit0_eqb".
intros a. rewrite testbit_eqb. now nzsimpl.
Qed.

Lemma bit0_mod : forall a, a.[0] == a mod 2.
Proof. hammer_hook "NBits" "NBits.NBitsProp.bit0_mod".
intros a. rewrite testbit_spec'. now nzsimpl.
Qed.

Lemma testbit_odd : forall a n, a.[n] = odd (a>>n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_odd".
intros. now rewrite <- bit0_odd, shiftr_spec, add_0_l.
Qed.

Lemma bit_log2 : forall a, a~=0 -> a.[log2 a] = true.
Proof. hammer_hook "NBits" "NBits.NBitsProp.bit_log2".
intros a Ha.
assert (Ha' : 0 < a) by (generalize (le_0_l a); order).
destruct (log2_spec_alt a Ha') as (r & EQ & (_,Hr)).
rewrite EQ at 1.
rewrite testbit_true, add_comm.
rewrite <- (mul_1_l (2^log2 a)) at 1.
rewrite div_add by order_nz.
rewrite div_small by trivial.
rewrite add_0_l. apply mod_small. order'.
Qed.

Lemma bits_above_log2 : forall a n, log2 a < n ->
a.[n] = false.
Proof. hammer_hook "NBits" "NBits.NBitsProp.bits_above_log2".
intros a n H.
rewrite testbit_false.
rewrite div_small. nzsimpl; order'.
apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l.
Qed.

Lemma div2_bits : forall a n, (a/2).[n] = a.[S n].
Proof. hammer_hook "NBits" "NBits.NBitsProp.div2_bits".
intros. apply eq_true_iff_eq.
rewrite 2 testbit_true.
rewrite pow_succ_r by apply le_0_l.
now rewrite div_div by order_nz.
Qed.

Lemma div_pow2_bits : forall a n m, (a/2^n).[m] = a.[m+n].
Proof. hammer_hook "NBits" "NBits.NBitsProp.div_pow2_bits".
intros a n. revert a. induct n.
intros a m. now nzsimpl.
intros n IH a m. nzsimpl; try apply le_0_l.
rewrite <- div_div by order_nz.
now rewrite IH, div2_bits.
Qed.

Lemma double_bits_succ : forall a n, (2*a).[S n] = a.[n].
Proof. hammer_hook "NBits" "NBits.NBitsProp.double_bits_succ".
intros. rewrite <- div2_bits. now rewrite mul_comm, div_mul by order'.
Qed.

Lemma mul_pow2_bits_add : forall a n m, (a*2^n).[m+n] = a.[m].
Proof. hammer_hook "NBits" "NBits.NBitsProp.mul_pow2_bits_add".
intros. rewrite <- div_pow2_bits. now rewrite div_mul by order_nz.
Qed.

Lemma mul_pow2_bits_high : forall a n m, n<=m -> (a*2^n).[m] = a.[m-n].
Proof. hammer_hook "NBits" "NBits.NBitsProp.mul_pow2_bits_high".
intros.
rewrite <- (sub_add n m) at 1 by order'.
now rewrite mul_pow2_bits_add.
Qed.

Lemma mul_pow2_bits_low : forall a n m, m<n -> (a*2^n).[m] = false.
Proof. hammer_hook "NBits" "NBits.NBitsProp.mul_pow2_bits_low".
intros. apply testbit_false.
rewrite <- (sub_add m n) by order'. rewrite pow_add_r, mul_assoc.
rewrite div_mul by order_nz.
rewrite <- (succ_pred (n-m)). rewrite pow_succ_r.
now rewrite (mul_comm 2), mul_assoc, mod_mul by order'.
apply lt_le_pred.
apply sub_gt in H. generalize (le_0_l (n-m)); order.
now apply sub_gt.
Qed.

Lemma mod_pow2_bits_high : forall a n m, n<=m ->
(a mod 2^n).[m] = false.
Proof. hammer_hook "NBits" "NBits.NBitsProp.mod_pow2_bits_high".
intros a n m H.
destruct (eq_0_gt_0_cases (a mod 2^n)) as [EQ|LT].
now rewrite EQ, bits_0.
apply bits_above_log2.
apply lt_le_trans with n; trivial.
apply log2_lt_pow2; trivial.
apply mod_upper_bound; order_nz.
Qed.

Lemma mod_pow2_bits_low : forall a n m, m<n ->
(a mod 2^n).[m] = a.[m].
Proof. hammer_hook "NBits" "NBits.NBitsProp.mod_pow2_bits_low".
intros a n m H.
rewrite testbit_eqb.
rewrite <- (mod_add _ (2^(P (n-m))*(a/2^n))) by order'.
rewrite <- div_add by order_nz.
rewrite (mul_comm _ 2), mul_assoc, <- pow_succ_r', succ_pred
by now apply sub_gt.
rewrite mul_comm, mul_assoc, <- pow_add_r, (add_comm m), sub_add
by order.
rewrite add_comm, <- div_mod by order_nz.
symmetry. apply testbit_eqb.
Qed.

Definition eqf (f g:t -> bool) := forall n:t, f n = g n.

Instance eqf_equiv : Equivalence eqf.
Proof. hammer_hook "NBits" "NBits.NBitsProp.eqf_equiv".
split; congruence.
Qed.

Local Infix "===" := eqf (at level 70, no associativity).

Instance testbit_eqf : Proper (eq==>eqf) testbit.
Proof. hammer_hook "NBits" "NBits.NBitsProp.testbit_eqf".
intros a a' Ha n. now rewrite Ha.
Qed.

Lemma bits_inj_0 :
forall a, (forall n, a.[n] = false) -> a == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.bits_inj_0".
intros a H. destruct (eq_decidable a 0) as [EQ|NEQ]; trivial.
apply bit_log2 in NEQ. now rewrite H in NEQ.
Qed.

Lemma bits_inj : forall a b, testbit a === testbit b -> a == b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.bits_inj".
intros a. pattern a.
apply strong_right_induction with 0;[solve_proper|clear a|apply le_0_l].
intros a _ IH b H.
destruct (eq_0_gt_0_cases a) as [EQ|LT].
rewrite EQ in H |- *. symmetry. apply bits_inj_0.
intros n. now rewrite <- H, bits_0.
rewrite (div_mod a 2), (div_mod b 2) by order'.
f_equiv; [ | now rewrite <- 2 bit0_mod, H].
f_equiv.
apply IH; trivial using le_0_l.
apply div_lt; order'.
intro n. rewrite 2 div2_bits. apply H.
Qed.

Lemma bits_inj_iff : forall a b, testbit a === testbit b <-> a == b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.bits_inj_iff".
split. apply bits_inj. intros EQ; now rewrite EQ.
Qed.

Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise.

Ltac bitwise := apply bits_inj; intros ?m; autorewrite with bitwise.

Lemma are_bits : forall (f:t->bool), Proper (eq==>Logic.eq) f ->
((exists n, f === testbit n) <->
(exists k, forall m, k<=m -> f m = false)).
Proof. hammer_hook "NBits" "NBits.NBitsProp.are_bits".
intros f Hf. split.
intros (a,H).
exists (S (log2 a)). intros m Hm. apply le_succ_l in Hm.
rewrite H, bits_above_log2; trivial using lt_succ_diag_r.
intros (k,Hk).
revert f Hf Hk. induct k.
intros f Hf H0.
exists 0. intros m. rewrite bits_0, H0; trivial. apply le_0_l.
intros k IH f Hf Hk.
destruct (IH (fun m => f (S m))) as (n, Hn).
solve_proper.
intros m Hm. apply Hk. now rewrite <- succ_le_mono.
exists (f 0 + 2*n). intros m.
destruct (zero_or_succ m) as [Hm|(m', Hm)]; rewrite Hm.
symmetry. apply add_b2n_double_bit0.
rewrite Hn, <- div2_bits.
rewrite mul_comm, div_add, b2n_div2, add_0_l; trivial. order'.
Qed.

Lemma shiftr_spec' : forall a n m, (a >> n).[m] = a.[m+n].
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_spec'".
intros. apply shiftr_spec. apply le_0_l.
Qed.

Lemma shiftl_spec_high' : forall a n m, n<=m -> (a << n).[m] = a.[m-n].
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_spec_high'".
intros. apply shiftl_spec_high; trivial. apply le_0_l.
Qed.

Lemma shiftr_div_pow2 : forall a n, a >> n == a / 2^n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_div_pow2".
intros. bitwise. rewrite shiftr_spec'.
symmetry. apply div_pow2_bits.
Qed.

Lemma shiftl_mul_pow2 : forall a n, a << n == a * 2^n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_mul_pow2".
intros. bitwise.
destruct (le_gt_cases n m) as [H|H].
now rewrite shiftl_spec_high', mul_pow2_bits_high.
now rewrite shiftl_spec_low, mul_pow2_bits_low.
Qed.

Lemma shiftl_spec_alt : forall a n m, (a << n).[m+n] = a.[m].
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_spec_alt".
intros. now rewrite shiftl_mul_pow2, mul_pow2_bits_add.
Qed.

Instance shiftr_wd : Proper (eq==>eq==>eq) shiftr.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_wd".
intros a a' Ha b b' Hb. now rewrite 2 shiftr_div_pow2, Ha, Hb.
Qed.

Instance shiftl_wd : Proper (eq==>eq==>eq) shiftl.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_wd".
intros a a' Ha b b' Hb. now rewrite 2 shiftl_mul_pow2, Ha, Hb.
Qed.

Lemma shiftl_shiftl : forall a n m,
(a << n) << m == a << (n+m).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_shiftl".
intros. now rewrite !shiftl_mul_pow2, pow_add_r, mul_assoc.
Qed.

Lemma shiftr_shiftr : forall a n m,
(a >> n) >> m == a >> (n+m).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_shiftr".
intros.
now rewrite !shiftr_div_pow2, pow_add_r, div_div by order_nz.
Qed.

Lemma shiftr_shiftl_l : forall a n m, m<=n ->
(a << n) >> m == a << (n-m).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_shiftl_l".
intros.
rewrite shiftr_div_pow2, !shiftl_mul_pow2.
rewrite <- (sub_add m n) at 1 by trivial.
now rewrite pow_add_r, mul_assoc, div_mul by order_nz.
Qed.

Lemma shiftr_shiftl_r : forall a n m, n<=m ->
(a << n) >> m == a >> (m-n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_shiftl_r".
intros.
rewrite !shiftr_div_pow2, shiftl_mul_pow2.
rewrite <- (sub_add n m) at 1 by trivial.
rewrite pow_add_r, (mul_comm (2^(m-n))).
now rewrite <- div_div, div_mul by order_nz.
Qed.

Lemma shiftl_1_l : forall n, 1 << n == 2^n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_1_l".
intros. now rewrite shiftl_mul_pow2, mul_1_l.
Qed.

Lemma shiftl_0_r : forall a, a << 0 == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_0_r".
intros. rewrite shiftl_mul_pow2. now nzsimpl.
Qed.

Lemma shiftr_0_r : forall a, a >> 0 == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_0_r".
intros. rewrite shiftr_div_pow2. now nzsimpl.
Qed.

Lemma shiftl_0_l : forall n, 0 << n == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_0_l".
intros. rewrite shiftl_mul_pow2. now nzsimpl.
Qed.

Lemma shiftr_0_l : forall n, 0 >> n == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_0_l".
intros. rewrite shiftr_div_pow2. nzsimpl; order_nz.
Qed.

Lemma shiftl_eq_0_iff : forall a n, a << n == 0 <-> a == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_eq_0_iff".
intros a n. rewrite shiftl_mul_pow2. rewrite eq_mul_0. split.
intros [H | H]; trivial. contradict H; order_nz.
intros H. now left.
Qed.

Lemma shiftr_eq_0_iff : forall a n,
a >> n == 0 <-> a==0 \/ (0<a /\ log2 a < n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_eq_0_iff".
intros a n.
rewrite shiftr_div_pow2, div_small_iff by order_nz.
destruct (eq_0_gt_0_cases a) as [EQ|LT].
rewrite EQ. split. now left. intros _.
assert (H : 2~=0) by order'.
generalize (pow_nonzero 2 n H) (le_0_l (2^n)); order.
rewrite log2_lt_pow2; trivial.
split. right; split; trivial. intros [H|[_ H]]; now order.
Qed.

Lemma shiftr_eq_0 : forall a n, log2 a < n -> a >> n == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_eq_0".
intros a n H. rewrite shiftr_eq_0_iff.
destruct (eq_0_gt_0_cases a) as [EQ|LT]. now left. right; now split.
Qed.

Lemma div2_div : forall a, div2 a == a/2.
Proof. hammer_hook "NBits" "NBits.NBitsProp.div2_div".
intros. rewrite div2_spec, shiftr_div_pow2. now nzsimpl.
Qed.

Instance div2_wd : Proper (eq==>eq) div2.
Proof. hammer_hook "NBits" "NBits.NBitsProp.div2_wd".
intros a a' Ha. now rewrite 2 div2_div, Ha.
Qed.

Lemma div2_odd : forall a, a == 2*(div2 a) + odd a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.div2_odd".
intros a. rewrite div2_div, <- bit0_odd, bit0_mod.
apply div_mod. order'.
Qed.

Instance lxor_wd : Proper (eq ==> eq ==> eq) lxor.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_wd".
intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
Qed.

Instance land_wd : Proper (eq ==> eq ==> eq) land.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_wd".
intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
Qed.

Instance lor_wd : Proper (eq ==> eq ==> eq) lor.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_wd".
intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
Qed.

Instance ldiff_wd : Proper (eq ==> eq ==> eq) ldiff.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_wd".
intros a a' Ha b b' Hb. bitwise. now rewrite Ha, Hb.
Qed.

Lemma lxor_eq : forall a a', lxor a a' == 0 -> a == a'.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_eq".
intros a a' H. bitwise. apply xorb_eq.
now rewrite <- lxor_spec, H, bits_0.
Qed.

Lemma lxor_nilpotent : forall a, lxor a a == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_nilpotent".
intros. bitwise. apply xorb_nilpotent.
Qed.

Lemma lxor_eq_0_iff : forall a a', lxor a a' == 0 <-> a == a'.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_eq_0_iff".
split. apply lxor_eq. intros EQ; rewrite EQ; apply lxor_nilpotent.
Qed.

Lemma lxor_0_l : forall a, lxor 0 a == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_0_l".
intros. bitwise. apply xorb_false_l.
Qed.

Lemma lxor_0_r : forall a, lxor a 0 == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_0_r".
intros. bitwise. apply xorb_false_r.
Qed.

Lemma lxor_comm : forall a b, lxor a b == lxor b a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_comm".
intros. bitwise. apply xorb_comm.
Qed.

Lemma lxor_assoc :
forall a b c, lxor (lxor a b) c == lxor a (lxor b c).
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_assoc".
intros. bitwise. apply xorb_assoc.
Qed.

Lemma lor_0_l : forall a, lor 0 a == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_0_l".
intros. bitwise. trivial.
Qed.

Lemma lor_0_r : forall a, lor a 0 == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_0_r".
intros. bitwise. apply orb_false_r.
Qed.

Lemma lor_comm : forall a b, lor a b == lor b a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_comm".
intros. bitwise. apply orb_comm.
Qed.

Lemma lor_assoc :
forall a b c, lor a (lor b c) == lor (lor a b) c.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_assoc".
intros. bitwise. apply orb_assoc.
Qed.

Lemma lor_diag : forall a, lor a a == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_diag".
intros. bitwise. apply orb_diag.
Qed.

Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_eq_0_l".
intros a b H. bitwise.
apply (orb_false_iff a.[m] b.[m]).
now rewrite <- lor_spec, H, bits_0.
Qed.

Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_eq_0_iff".
intros a b. split.
split. now apply lor_eq_0_l in H.
rewrite lor_comm in H. now apply lor_eq_0_l in H.
intros (EQ,EQ'). now rewrite EQ, lor_0_l.
Qed.

Lemma land_0_l : forall a, land 0 a == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_0_l".
intros. bitwise. trivial.
Qed.

Lemma land_0_r : forall a, land a 0 == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_0_r".
intros. bitwise. apply andb_false_r.
Qed.

Lemma land_comm : forall a b, land a b == land b a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_comm".
intros. bitwise. apply andb_comm.
Qed.

Lemma land_assoc :
forall a b c, land a (land b c) == land (land a b) c.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_assoc".
intros. bitwise. apply andb_assoc.
Qed.

Lemma land_diag : forall a, land a a == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_diag".
intros. bitwise. apply andb_diag.
Qed.

Lemma ldiff_0_l : forall a, ldiff 0 a == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_0_l".
intros. bitwise. trivial.
Qed.

Lemma ldiff_0_r : forall a, ldiff a 0 == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_0_r".
intros. bitwise. now rewrite andb_true_r.
Qed.

Lemma ldiff_diag : forall a, ldiff a a == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_diag".
intros. bitwise. apply andb_negb_r.
Qed.

Lemma lor_land_distr_l : forall a b c,
lor (land a b) c == land (lor a c) (lor b c).
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_land_distr_l".
intros. bitwise. apply orb_andb_distrib_l.
Qed.

Lemma lor_land_distr_r : forall a b c,
lor a (land b c) == land (lor a b) (lor a c).
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_land_distr_r".
intros. bitwise. apply orb_andb_distrib_r.
Qed.

Lemma land_lor_distr_l : forall a b c,
land (lor a b) c == lor (land a c) (land b c).
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_lor_distr_l".
intros. bitwise. apply andb_orb_distrib_l.
Qed.

Lemma land_lor_distr_r : forall a b c,
land a (lor b c) == lor (land a b) (land a c).
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_lor_distr_r".
intros. bitwise. apply andb_orb_distrib_r.
Qed.

Lemma ldiff_ldiff_l : forall a b c,
ldiff (ldiff a b) c == ldiff a (lor b c).
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_ldiff_l".
intros. bitwise. now rewrite negb_orb, andb_assoc.
Qed.

Lemma lor_ldiff_and : forall a b,
lor (ldiff a b) (land a b) == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_ldiff_and".
intros. bitwise.
now rewrite <- andb_orb_distrib_r, orb_comm, orb_negb_r, andb_true_r.
Qed.

Lemma land_ldiff : forall a b,
land (ldiff a b) b == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_ldiff".
intros. bitwise.
now rewrite <-andb_assoc, (andb_comm (negb _)), andb_negb_r, andb_false_r.
Qed.

Definition setbit a n := lor a (1<<n).
Definition clearbit a n := ldiff a (1<<n).

Lemma setbit_spec' : forall a n, setbit a n == lor a (2^n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.setbit_spec'".
intros. unfold setbit. now rewrite shiftl_1_l.
Qed.

Lemma clearbit_spec' : forall a n, clearbit a n == ldiff a (2^n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.clearbit_spec'".
intros. unfold clearbit. now rewrite shiftl_1_l.
Qed.

Instance setbit_wd : Proper (eq==>eq==>eq) setbit.
Proof. hammer_hook "NBits" "NBits.NBitsProp.setbit_wd".   unfold setbit. solve_proper. Qed.

Instance clearbit_wd : Proper (eq==>eq==>eq) clearbit.
Proof. hammer_hook "NBits" "NBits.NBitsProp.clearbit_wd".   unfold clearbit. solve_proper. Qed.

Lemma pow2_bits_true : forall n, (2^n).[n] = true.
Proof. hammer_hook "NBits" "NBits.NBitsProp.pow2_bits_true".
intros. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2.
now rewrite mul_pow2_bits_add, bit0_odd, odd_1.
Qed.

Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false.
Proof. hammer_hook "NBits" "NBits.NBitsProp.pow2_bits_false".
intros.
rewrite <- (mul_1_l (2^n)).
destruct (le_gt_cases n m).
rewrite mul_pow2_bits_high; trivial.
rewrite <- (succ_pred (m-n)) by (apply sub_gt; order).
now rewrite <- div2_bits, div_small, bits_0 by order'.
rewrite mul_pow2_bits_low; trivial.
Qed.

Lemma pow2_bits_eqb : forall n m, (2^n).[m] = eqb n m.
Proof. hammer_hook "NBits" "NBits.NBitsProp.pow2_bits_eqb".
intros. apply eq_true_iff_eq. rewrite eqb_eq. split.
destruct (eq_decidable n m) as [H|H]. trivial.
now rewrite (pow2_bits_false _ _ H).
intros EQ. rewrite EQ. apply pow2_bits_true.
Qed.

Lemma setbit_eqb : forall a n m,
(setbit a n).[m] = eqb n m || a.[m].
Proof. hammer_hook "NBits" "NBits.NBitsProp.setbit_eqb".
intros. now rewrite setbit_spec', lor_spec, pow2_bits_eqb, orb_comm.
Qed.

Lemma setbit_iff : forall a n m,
(setbit a n).[m] = true <-> n==m \/ a.[m] = true.
Proof. hammer_hook "NBits" "NBits.NBitsProp.setbit_iff".
intros. now rewrite setbit_eqb, orb_true_iff, eqb_eq.
Qed.

Lemma setbit_eq : forall a n, (setbit a n).[n] = true.
Proof. hammer_hook "NBits" "NBits.NBitsProp.setbit_eq".
intros. apply setbit_iff. now left.
Qed.

Lemma setbit_neq : forall a n m, n~=m ->
(setbit a n).[m] = a.[m].
Proof. hammer_hook "NBits" "NBits.NBitsProp.setbit_neq".
intros a n m H. rewrite setbit_eqb.
rewrite <- eqb_eq in H. apply not_true_is_false in H. now rewrite H.
Qed.

Lemma clearbit_eqb : forall a n m,
(clearbit a n).[m] = a.[m] && negb (eqb n m).
Proof. hammer_hook "NBits" "NBits.NBitsProp.clearbit_eqb".
intros. now rewrite clearbit_spec', ldiff_spec, pow2_bits_eqb.
Qed.

Lemma clearbit_iff : forall a n m,
(clearbit a n).[m] = true <-> a.[m] = true /\ n~=m.
Proof. hammer_hook "NBits" "NBits.NBitsProp.clearbit_iff".
intros. rewrite clearbit_eqb, andb_true_iff, <- eqb_eq.
now rewrite negb_true_iff, not_true_iff_false.
Qed.

Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false.
Proof. hammer_hook "NBits" "NBits.NBitsProp.clearbit_eq".
intros. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)).
apply andb_false_r.
Qed.

Lemma clearbit_neq : forall a n m, n~=m ->
(clearbit a n).[m] = a.[m].
Proof. hammer_hook "NBits" "NBits.NBitsProp.clearbit_neq".
intros a n m H. rewrite clearbit_eqb.
rewrite <- eqb_eq in H. apply not_true_is_false in H. rewrite H.
apply andb_true_r.
Qed.

Lemma shiftl_lxor : forall a b n,
(lxor a b) << n == lxor (a << n) (b << n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_lxor".
intros. bitwise.
destruct (le_gt_cases n m).
now rewrite !shiftl_spec_high', lxor_spec.
now rewrite !shiftl_spec_low.
Qed.

Lemma shiftr_lxor : forall a b n,
(lxor a b) >> n == lxor (a >> n) (b >> n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_lxor".
intros. bitwise. now rewrite !shiftr_spec', lxor_spec.
Qed.

Lemma shiftl_land : forall a b n,
(land a b) << n == land (a << n) (b << n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_land".
intros. bitwise.
destruct (le_gt_cases n m).
now rewrite !shiftl_spec_high', land_spec.
now rewrite !shiftl_spec_low.
Qed.

Lemma shiftr_land : forall a b n,
(land a b) >> n == land (a >> n) (b >> n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_land".
intros. bitwise. now rewrite !shiftr_spec', land_spec.
Qed.

Lemma shiftl_lor : forall a b n,
(lor a b) << n == lor (a << n) (b << n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_lor".
intros. bitwise.
destruct (le_gt_cases n m).
now rewrite !shiftl_spec_high', lor_spec.
now rewrite !shiftl_spec_low.
Qed.

Lemma shiftr_lor : forall a b n,
(lor a b) >> n == lor (a >> n) (b >> n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_lor".
intros. bitwise. now rewrite !shiftr_spec', lor_spec.
Qed.

Lemma shiftl_ldiff : forall a b n,
(ldiff a b) << n == ldiff (a << n) (b << n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftl_ldiff".
intros. bitwise.
destruct (le_gt_cases n m).
now rewrite !shiftl_spec_high', ldiff_spec.
now rewrite !shiftl_spec_low.
Qed.

Lemma shiftr_ldiff : forall a b n,
(ldiff a b) >> n == ldiff (a >> n) (b >> n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.shiftr_ldiff".
intros. bitwise. now rewrite !shiftr_spec', ldiff_spec.
Qed.

Definition ones n := P (1 << n).

Definition lnot a n := lxor a (ones n).

Instance ones_wd : Proper (eq==>eq) ones.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ones_wd".   unfold ones. solve_proper. Qed.

Instance lnot_wd : Proper (eq==>eq==>eq) lnot.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_wd".   unfold lnot. solve_proper. Qed.

Lemma ones_equiv : forall n, ones n == P (2^n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.ones_equiv".
intros; unfold ones; now rewrite shiftl_1_l.
Qed.

Lemma ones_add : forall n m, ones (m+n) == 2^m * ones n + ones m.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ones_add".
intros n m. rewrite !ones_equiv.
rewrite <- !sub_1_r, mul_sub_distr_l, mul_1_r, <- pow_add_r.
rewrite add_sub_assoc, sub_add. reflexivity.
apply pow_le_mono_r. order'.
rewrite <- (add_0_r m) at 1. apply add_le_mono_l, le_0_l.
rewrite <- (pow_0_r 2). apply pow_le_mono_r. order'. apply le_0_l.
Qed.

Lemma ones_div_pow2 : forall n m, m<=n -> ones n / 2^m == ones (n-m).
Proof. hammer_hook "NBits" "NBits.NBitsProp.ones_div_pow2".
intros n m H. symmetry. apply div_unique with (ones m).
rewrite ones_equiv.
apply le_succ_l. rewrite succ_pred; order_nz.
rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m).
apply ones_add.
Qed.

Lemma ones_mod_pow2 : forall n m, m<=n -> (ones n) mod (2^m) == ones m.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ones_mod_pow2".
intros n m H. symmetry. apply mod_unique with (ones (n-m)).
rewrite ones_equiv.
apply le_succ_l. rewrite succ_pred; order_nz.
rewrite <- (sub_add m n H) at 1. rewrite (add_comm _ m).
apply ones_add.
Qed.

Lemma ones_spec_low : forall n m, m<n -> (ones n).[m] = true.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ones_spec_low".
intros. apply testbit_true. rewrite ones_div_pow2 by order.
rewrite <- (pow_1_r 2). rewrite ones_mod_pow2.
rewrite ones_equiv. now nzsimpl'.
apply le_add_le_sub_r. nzsimpl. now apply le_succ_l.
Qed.

Lemma ones_spec_high : forall n m, n<=m -> (ones n).[m] = false.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ones_spec_high".
intros.
destruct (eq_0_gt_0_cases n) as [EQ|LT]; rewrite ones_equiv.
now rewrite EQ, pow_0_r, one_succ, pred_succ, bits_0.
apply bits_above_log2.
rewrite log2_pred_pow2; trivial. rewrite <-le_succ_l, succ_pred; order.
Qed.

Lemma ones_spec_iff : forall n m, (ones n).[m] = true <-> m<n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ones_spec_iff".
intros. split. intros H.
apply lt_nge. intro H'. apply ones_spec_high in H'.
rewrite H in H'; discriminate.
apply ones_spec_low.
Qed.

Lemma lnot_spec_low : forall a n m, m<n ->
(lnot a n).[m] = negb a.[m].
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_spec_low".
intros. unfold lnot. now rewrite lxor_spec, ones_spec_low.
Qed.

Lemma lnot_spec_high : forall a n m, n<=m ->
(lnot a n).[m] = a.[m].
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_spec_high".
intros. unfold lnot. now rewrite lxor_spec, ones_spec_high, xorb_false_r.
Qed.

Lemma lnot_involutive : forall a n, lnot (lnot a n) n == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_involutive".
intros a n. bitwise.
destruct (le_gt_cases n m).
now rewrite 2 lnot_spec_high.
now rewrite 2 lnot_spec_low, negb_involutive.
Qed.

Lemma lnot_0_l : forall n, lnot 0 n == ones n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_0_l".
intros. unfold lnot. apply lxor_0_l.
Qed.

Lemma lnot_ones : forall n, lnot (ones n) n == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_ones".
intros. unfold lnot. apply lxor_nilpotent.
Qed.

Lemma lor_ones_low : forall a n, log2 a < n ->
lor a (ones n) == ones n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_ones_low".
intros a n H. bitwise. destruct (le_gt_cases n m).
rewrite ones_spec_high, bits_above_log2; trivial.
now apply lt_le_trans with n.
now rewrite ones_spec_low, orb_true_r.
Qed.

Lemma land_ones : forall a n, land a (ones n) == a mod 2^n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_ones".
intros a n. bitwise. destruct (le_gt_cases n m).
now rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r.
now rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r.
Qed.

Lemma land_ones_low : forall a n, log2 a < n ->
land a (ones n) == a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_ones_low".
intros; rewrite land_ones. apply mod_small.
apply log2_lt_cancel. rewrite log2_pow2; trivial using le_0_l.
Qed.

Lemma ldiff_ones_r : forall a n,
ldiff a (ones n) == (a >> n) << n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_ones_r".
intros a n. bitwise. destruct (le_gt_cases n m).
rewrite ones_spec_high, shiftl_spec_high', shiftr_spec'; trivial.
rewrite sub_add; trivial. apply andb_true_r.
now rewrite ones_spec_low, shiftl_spec_low, andb_false_r.
Qed.

Lemma ldiff_ones_r_low : forall a n, log2 a < n ->
ldiff a (ones n) == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_ones_r_low".
intros a n H. bitwise. destruct (le_gt_cases n m).
rewrite ones_spec_high, bits_above_log2; trivial.
now apply lt_le_trans with n.
now rewrite ones_spec_low, andb_false_r.
Qed.

Lemma ldiff_ones_l_low : forall a n, log2 a < n ->
ldiff (ones n) a == lnot a n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_ones_l_low".
intros a n H. bitwise. destruct (le_gt_cases n m).
rewrite ones_spec_high, lnot_spec_high, bits_above_log2; trivial.
now apply lt_le_trans with n.
now rewrite ones_spec_low, lnot_spec_low.
Qed.

Lemma lor_lnot_diag : forall a n,
lor a (lnot a n) == lor a (ones n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_lnot_diag".
intros a n. bitwise.
destruct (le_gt_cases n m).
rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m].
rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m].
Qed.

Lemma lor_lnot_diag_low : forall a n, log2 a < n ->
lor a (lnot a n) == ones n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lor_lnot_diag_low".
intros a n H. now rewrite lor_lnot_diag, lor_ones_low.
Qed.

Lemma land_lnot_diag : forall a n,
land a (lnot a n) == ldiff a (ones n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_lnot_diag".
intros a n. bitwise.
destruct (le_gt_cases n m).
rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m].
rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m].
Qed.

Lemma land_lnot_diag_low : forall a n, log2 a < n ->
land a (lnot a n) == 0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.land_lnot_diag_low".
intros. now rewrite land_lnot_diag, ldiff_ones_r_low.
Qed.

Lemma lnot_lor_low : forall a b n, log2 a < n -> log2 b < n ->
lnot (lor a b) n == land (lnot a n) (lnot b n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_lor_low".
intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m).
rewrite !lnot_spec_high, lor_spec, !bits_above_log2; trivial.
now apply lt_le_trans with n.
now apply lt_le_trans with n.
now rewrite !lnot_spec_low, lor_spec, negb_orb.
Qed.

Lemma lnot_land_low : forall a b n, log2 a < n -> log2 b < n ->
lnot (land a b) n == lor (lnot a n) (lnot b n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_land_low".
intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m).
rewrite !lnot_spec_high, land_spec, !bits_above_log2; trivial.
now apply lt_le_trans with n.
now apply lt_le_trans with n.
now rewrite !lnot_spec_low, land_spec, negb_andb.
Qed.

Lemma ldiff_land_low : forall a b n, log2 a < n ->
ldiff a b == land a (lnot b n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_land_low".
intros a b n Ha. bitwise. destruct (le_gt_cases n m).
rewrite (bits_above_log2 a m). trivial.
now apply lt_le_trans with n.
rewrite !lnot_spec_low; trivial.
Qed.

Lemma lnot_ldiff_low : forall a b n, log2 a < n -> log2 b < n ->
lnot (ldiff a b) n == lor (lnot a n) b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_ldiff_low".
intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m).
rewrite !lnot_spec_high, ldiff_spec, !bits_above_log2; trivial.
now apply lt_le_trans with n.
now apply lt_le_trans with n.
now rewrite !lnot_spec_low, ldiff_spec, negb_andb, negb_involutive.
Qed.

Lemma lxor_lnot_lnot : forall a b n,
lxor (lnot a n) (lnot b n) == lxor a b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_lnot_lnot".
intros a b n. bitwise. destruct (le_gt_cases n m).
rewrite !lnot_spec_high; trivial.
rewrite !lnot_spec_low, xorb_negb_negb; trivial.
Qed.

Lemma lnot_lxor_l : forall a b n,
lnot (lxor a b) n == lxor (lnot a n) b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_lxor_l".
intros a b n. bitwise. destruct (le_gt_cases n m).
rewrite !lnot_spec_high, lxor_spec; trivial.
rewrite !lnot_spec_low, lxor_spec, negb_xorb_l; trivial.
Qed.

Lemma lnot_lxor_r : forall a b n,
lnot (lxor a b) n == lxor a (lnot b n).
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_lxor_r".
intros a b n. bitwise. destruct (le_gt_cases n m).
rewrite !lnot_spec_high, lxor_spec; trivial.
rewrite !lnot_spec_low, lxor_spec, negb_xorb_r; trivial.
Qed.

Lemma lxor_lor : forall a b, land a b == 0 ->
lxor a b == lor a b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lxor_lor".
intros a b H. bitwise.
assert (a.[m] && b.[m] = false)
by now rewrite <- land_spec, H, bits_0.
now destruct a.[m], b.[m].
Qed.

Lemma log2_bits_unique : forall a n,
a.[n] = true ->
(forall m, n<m -> a.[m] = false) ->
log2 a == n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.log2_bits_unique".
intros a n H H'.
destruct (eq_0_gt_0_cases a) as [Ha|Ha].
now rewrite Ha, bits_0 in H.
apply le_antisymm; apply le_ngt; intros LT.
specialize (H' _ LT). now rewrite bit_log2 in H' by order.
now rewrite bits_above_log2 in H by order.
Qed.

Lemma log2_shiftr : forall a n, log2 (a >> n) == log2 a - n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.log2_shiftr".
intros a n.
destruct (eq_0_gt_0_cases a) as [Ha|Ha].
now rewrite Ha, shiftr_0_l, log2_nonpos, sub_0_l by order.
destruct (lt_ge_cases (log2 a) n).
rewrite shiftr_eq_0, log2_nonpos by order.
symmetry. rewrite sub_0_le; order.
apply log2_bits_unique.
now rewrite shiftr_spec', sub_add, bit_log2 by order.
intros m Hm.
rewrite shiftr_spec'; trivial. apply bits_above_log2; try order.
now apply lt_sub_lt_add_r.
Qed.

Lemma log2_shiftl : forall a n, a~=0 -> log2 (a << n) == log2 a + n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.log2_shiftl".
intros a n Ha.
rewrite shiftl_mul_pow2, add_comm by trivial.
apply log2_mul_pow2. generalize (le_0_l a); order. apply le_0_l.
Qed.

Lemma log2_lor : forall a b,
log2 (lor a b) == max (log2 a) (log2 b).
Proof. hammer_hook "NBits" "NBits.NBitsProp.log2_lor".
assert (AUX : forall a b, a<=b -> log2 (lor a b) == log2 b).
intros a b H.
destruct (eq_0_gt_0_cases a) as [Ha|Ha]. now rewrite Ha, lor_0_l.
apply log2_bits_unique.
now rewrite lor_spec, bit_log2, orb_true_r by order.
intros m Hm. assert (H' := log2_le_mono _ _ H).
now rewrite lor_spec, 2 bits_above_log2 by order.

intros a b. destruct (le_ge_cases a b) as [H|H].
rewrite max_r by now apply log2_le_mono.
now apply AUX.
rewrite max_l by now apply log2_le_mono.
rewrite lor_comm. now apply AUX.
Qed.

Lemma log2_land : forall a b,
log2 (land a b) <= min (log2 a) (log2 b).
Proof. hammer_hook "NBits" "NBits.NBitsProp.log2_land".
assert (AUX : forall a b, a<=b -> log2 (land a b) <= log2 a).
intros a b H.
apply le_ngt. intros H'.
destruct (eq_decidable (land a b) 0) as [EQ|NEQ].
rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order.
generalize (bit_log2 (land a b) NEQ).
now rewrite land_spec, bits_above_log2.

intros a b.
destruct (le_ge_cases a b) as [H|H].
rewrite min_l by now apply log2_le_mono. now apply AUX.
rewrite min_r by now apply log2_le_mono. rewrite land_comm. now apply AUX.
Qed.

Lemma log2_lxor : forall a b,
log2 (lxor a b) <= max (log2 a) (log2 b).
Proof. hammer_hook "NBits" "NBits.NBitsProp.log2_lxor".
assert (AUX : forall a b, a<=b -> log2 (lxor a b) <= log2 b).
intros a b H.
apply le_ngt. intros H'.
destruct (eq_decidable (lxor a b) 0) as [EQ|NEQ].
rewrite EQ in H'. apply log2_lt_cancel in H'. generalize (le_0_l a); order.
generalize (bit_log2 (lxor a b) NEQ).
rewrite lxor_spec, 2 bits_above_log2; try order. discriminate.
apply le_lt_trans with (log2 b); trivial. now apply log2_le_mono.

intros a b.
destruct (le_ge_cases a b) as [H|H].
rewrite max_r by now apply log2_le_mono. now apply AUX.
rewrite max_l by now apply log2_le_mono. rewrite lxor_comm. now apply AUX.
Qed.

Local Notation xor3 a b c := (xorb (xorb a b) c).
Local Notation lxor3 a b c := (lxor (lxor a b) c).

Local Notation nextcarry a b c := ((a&&b) || (c && (a||b))).
Local Notation lnextcarry a b c := (lor (land a b) (land c (lor a b))).

Lemma add_bit0 : forall a b, (a+b).[0] = xorb a.[0] b.[0].
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_bit0".
intros. now rewrite !bit0_odd, odd_add.
Qed.

Lemma add3_bit0 : forall a b c,
(a+b+c).[0] = xor3 a.[0] b.[0] c.[0].
Proof. hammer_hook "NBits" "NBits.NBitsProp.add3_bit0".
intros. now rewrite !add_bit0.
Qed.

Lemma add3_bits_div2 : forall (a0 b0 c0 : bool),
(a0 + b0 + c0)/2 == nextcarry a0 b0 c0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.add3_bits_div2".
assert (H : 1+1 == 2) by now nzsimpl'.
intros [|] [|] [|]; simpl; rewrite ?add_0_l, ?add_0_r, ?H;
(apply div_same; order') || (apply div_small; order') || idtac.
symmetry. apply div_unique with 1. order'. now nzsimpl'.
Qed.

Lemma add_carry_div2 : forall a b (c0:bool),
(a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_carry_div2".
intros.
rewrite <- add3_bits_div2.
rewrite (add_comm ((a/2)+_)).
rewrite <- div_add by order'.
f_equiv.
rewrite <- !div2_div, mul_comm, mul_add_distr_l.
rewrite (div2_odd a), <- bit0_odd at 1. fold (b2n a.[0]).
rewrite (div2_odd b), <- bit0_odd at 1. fold (b2n b.[0]).
rewrite add_shuffle1.
rewrite <-(add_assoc _ _ c0). apply add_comm.
Qed.

Lemma add_carry_bits : forall a b (c0:bool), exists c,
a+b+c0 == lxor3 a b c /\ c/2 == lnextcarry a b c /\ c.[0] = c0.
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_carry_bits".
intros a b c0.

set (n:=max a b).
assert (Ha : a<2^n).
apply lt_le_trans with (2^a). apply pow_gt_lin_r, lt_1_2.
apply pow_le_mono_r. order'. unfold n.
destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'.
assert (Hb : b<2^n).
apply lt_le_trans with (2^b). apply pow_gt_lin_r, lt_1_2.
apply pow_le_mono_r. order'. unfold n.
destruct (le_ge_cases a b); [rewrite max_r|rewrite max_l]; order'.
clearbody n.
revert a b c0 Ha Hb. induct n.

intros a b c0. rewrite !pow_0_r, !one_succ, !lt_succ_r. intros Ha Hb.
exists c0.
setoid_replace a with 0 by (generalize (le_0_l a); order').
setoid_replace b with 0 by (generalize (le_0_l b); order').
rewrite !add_0_l, !lxor_0_l, !lor_0_r, !land_0_r, !lor_0_r.
rewrite b2n_div2, b2n_bit0; now repeat split.

intros n IH a b c0 Ha Hb.
set (c1:=nextcarry a.[0] b.[0] c0).
destruct (IH (a/2) (b/2) c1) as (c & IH1 & IH2 & Hc); clear IH.
apply div_lt_upper_bound; trivial. order'. now rewrite <- pow_succ_r'.
apply div_lt_upper_bound; trivial. order'. now rewrite <- pow_succ_r'.
exists (c0 + 2*c). repeat split.

bitwise.
destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ.
now rewrite add_b2n_double_bit0, add3_bit0, b2n_bit0.
rewrite <- !div2_bits, <- 2 lxor_spec.
f_equiv.
rewrite add_b2n_double_div2, <- IH1. apply add_carry_div2.

rewrite add_b2n_double_div2.
bitwise.
destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ.
now rewrite add_b2n_double_bit0.
rewrite <- !div2_bits, IH2. autorewrite with bitwise.
now rewrite add_b2n_double_div2.

apply add_b2n_double_bit0.
Qed.

Lemma add_bit1 : forall a b,
(a+b).[1] = xor3 a.[1] b.[1] (a.[0] && b.[0]).
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_bit1".
intros a b.
destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc).
simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1.
autorewrite with bitwise. f_equal.
rewrite one_succ, <- div2_bits, EQ2.
autorewrite with bitwise.
rewrite Hc. simpl. apply orb_false_r.
Qed.

Lemma nocarry_equiv : forall a b c,
c/2 == lnextcarry a b c -> c.[0] = false ->
(c == 0 <-> land a b == 0).
Proof. hammer_hook "NBits" "NBits.NBitsProp.nocarry_equiv".
intros a b c H H'.
split. intros EQ; rewrite EQ in *.
rewrite div_0_l in H by order'.
symmetry in H. now apply lor_eq_0_l in H.
intros EQ. rewrite EQ, lor_0_l in H.
apply bits_inj_0.
induct n. trivial.
intros n IH.
rewrite <- div2_bits, H.
autorewrite with bitwise.
now rewrite IH.
Qed.

Lemma add_nocarry_lxor : forall a b, land a b == 0 ->
a+b == lxor a b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_nocarry_lxor".
intros a b H.
destruct (add_carry_bits a b false) as (c & EQ1 & EQ2 & Hc).
simpl in EQ1; rewrite add_0_r in EQ1. rewrite EQ1.
apply (nocarry_equiv a b c) in H; trivial.
rewrite H. now rewrite lxor_0_r.
Qed.

Lemma ldiff_le : forall a b, ldiff a b == 0 -> a <= b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.ldiff_le".
cut (forall n a b, a < 2^n -> ldiff a b == 0 -> a <= b).
intros H a b. apply (H a), pow_gt_lin_r; order'.
induct n.
intros a b Ha _. rewrite pow_0_r, one_succ, lt_succ_r in Ha.
assert (Ha' : a == 0) by (generalize (le_0_l a); order').
rewrite Ha'. apply le_0_l.
intros n IH a b Ha H.
assert (NEQ : 2 ~= 0) by order'.
rewrite (div_mod a 2 NEQ), (div_mod b 2 NEQ).
apply add_le_mono.
apply mul_le_mono_l.
apply IH.
apply div_lt_upper_bound; trivial. now rewrite <- pow_succ_r'.
rewrite <- (pow_1_r 2), <- 2 shiftr_div_pow2.
now rewrite <- shiftr_ldiff, H, shiftr_div_pow2, pow_1_r, div_0_l.
rewrite <- 2 bit0_mod.
apply bits_inj_iff in H. specialize (H 0).
rewrite ldiff_spec, bits_0 in H.
destruct a.[0], b.[0]; try discriminate; simpl; order'.
Qed.

Lemma sub_nocarry_ldiff : forall a b, ldiff b a == 0 ->
a-b == ldiff a b.
Proof. hammer_hook "NBits" "NBits.NBitsProp.sub_nocarry_ldiff".
intros a b H.
apply add_cancel_r with b.
rewrite sub_add.
symmetry.
rewrite add_nocarry_lxor.
bitwise.
apply bits_inj_iff in H. specialize (H m).
rewrite ldiff_spec, bits_0 in H.
now destruct a.[m], b.[m].
apply land_ldiff.
now apply ldiff_le.
Qed.

Lemma add_lnot_diag_low : forall a n, log2 a < n ->
a + lnot a n == ones n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_lnot_diag_low".
intros a n H.
assert (H' := land_lnot_diag_low a n H).
rewrite add_nocarry_lxor, lxor_lor by trivial.
now apply lor_lnot_diag_low.
Qed.

Lemma lnot_sub_low : forall a n, log2 a < n ->
lnot a n == ones n - a.
Proof. hammer_hook "NBits" "NBits.NBitsProp.lnot_sub_low".
intros a n H.
now rewrite <- (add_lnot_diag_low a n H), add_comm, add_sub.
Qed.

Lemma add_nocarry_lt_pow2 : forall a b n, land a b == 0 ->
a < 2^n -> b < 2^n -> a+b < 2^n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_nocarry_lt_pow2".
intros a b n H Ha Hb.
rewrite add_nocarry_lxor by trivial.
apply div_small_iff. order_nz.
rewrite <- shiftr_div_pow2, shiftr_lxor, !shiftr_div_pow2.
rewrite 2 div_small by trivial.
apply lxor_0_l.
Qed.

Lemma add_nocarry_mod_lt_pow2 : forall a b n, land a b == 0 ->
a mod 2^n + b mod 2^n < 2^n.
Proof. hammer_hook "NBits" "NBits.NBitsProp.add_nocarry_mod_lt_pow2".
intros a b n H.
apply add_nocarry_lt_pow2.
bitwise.
destruct (le_gt_cases n m).
now rewrite mod_pow2_bits_high.
now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0.
apply mod_upper_bound; order_nz.
apply mod_upper_bound; order_nz.
Qed.

End NBitsProp.


Require Export ZArith.
Require Export Syntax.
Require Import FunctionalExtensionality.
Require Import Tactics.

(* External environments map observables to values. [ExtEnv'] is
parametrised over the type of values so that we can instantiate it
later to partial environments. *)

Definition ExtEnv' A := ObsLabel -> Z -> A.

Open Scope Z.

(* Move external environments into the future. *)

Definition adv_ext {A} (d : Z) (e : ExtEnv' A) : ExtEnv' A
  := fun l x => e l (d + x)%Z.

Lemma adv_ext_0 {A} (e : ExtEnv' A) : adv_ext 0 e = e.
Proof.
  apply functional_extensionality.
  unfold adv_ext. reflexivity.
Qed.

Lemma adv_ext_iter {A} d d' (e : ExtEnv' A) : adv_ext d (adv_ext d' e) = adv_ext (d' + d) e.
Proof.
  apply functional_extensionality. intro. apply functional_extensionality. induction d'; intros.
  - simpl. rewrite adv_ext_0. reflexivity.
  - simpl. unfold adv_ext in *.  rewrite Z.add_assoc. reflexivity.
  - unfold adv_ext. rewrite Z.add_assoc.  reflexivity.
Qed.

Lemma adv_ext_iter' {A} d d' (e : ExtEnv' A) : adv_ext d (adv_ext d' e) = adv_ext (d + d') e.
Proof.
  apply functional_extensionality. intro. apply functional_extensionality. destruct d; intros;
  unfold adv_ext; f_equal; omega.
Qed.

Lemma adv_ext_opp {A} d d' (e : ExtEnv' A) : d' + d = 0 -> adv_ext d (adv_ext d' e) = e.
Proof.
  intros. rewrite adv_ext_iter. rewrite H. apply adv_ext_0.
Qed.

Lemma adv_ext_swap {A} d d' (e : ExtEnv' A) :
  adv_ext d (adv_ext d' e) = adv_ext d' (adv_ext d e).
Proof.
  repeat rewrite adv_ext_iter. rewrite Z.add_comm. reflexivity.
Qed.

Lemma adv_ext_step {A} n (ext : ExtEnv' A) :
  ((adv_ext (- Z.of_nat (S n)) ext) = (adv_ext (- Z.of_nat n) (adv_ext (-1) ext))).
Proof.
  rewrite adv_ext_iter. f_equal. rewrite Nat2Z.inj_succ. omega.
Qed.

Lemma Zneg_of_succ_nat : forall n, Z.neg (Pos.of_succ_nat n) = (- Z.of_nat (S n))%Z.
Proof.
  intros. rewrite <- Pos2Z.opp_pos. rewrite Zpos_P_of_succ_nat. rewrite Nat2Z.inj_succ. reflexivity.
Qed.

Lemma adv_ext_step' {A} n (ext : ExtEnv' A) : ((adv_ext (Z.neg (Pos.of_succ_nat n)) ext)
                                               = (adv_ext (- Z.of_nat n) (adv_ext (-1) ext))).
Proof.
  rewrite Zneg_of_succ_nat. apply adv_ext_step.
Qed.

Definition Env' A := list A.

Fixpoint lookupEnv {A} (v : Var) (env : Env' A) : option A :=
  match v, env with
    | V1, x::_ => Some x
    | VS v, _::xs => lookupEnv v xs
    | _,_ => None
  end.


Set Warnings "-notation-overridden".

Require Export Coq.ZArith.ZArith.
Require Export Coq.Lists.List.
Require Import Coq.Sorting.Sorting Orders.
Require Import ssreflect.
Require Import Tweetnacl.Libs.Decidable.

Open Scope Z_scope.

Inductive term :=
  | Var   : positive -> term
  | Val   : Z -> term
  .

Definition term_decide (x y : term) : bool := match x , y with
  | Var x , Var y => Pos.eqb x y
  | Val x,  Val y => Z.eqb x y
  | _, _ => false
  end.

Lemma term_eqb_refl : forall x y, term_decide x y = true <-> x = y.
Proof.
move => x y ; rewrite /term_decide ; split => H ; simpl.
destruct x,y; move: H.
rewrite Pos.eqb_eq => -> //.
discriminate.
discriminate.
rewrite Z.eqb_eq => -> //.
subst ; destruct y.
rewrite Pos.eqb_eq //.
rewrite Z.eqb_eq //.
Qed.

Definition term_denote (env:environment) (x : term) : Z :=
  match x with
  | Var n => vars env n
  | Val n => n
  end.

Lemma term_decide_com : forall x y, term_decide x y = term_decide y x.
Proof.
move => [] a [] b //=.
rewrite ?Pos2Z.inj_eqb.
apply Z.eqb_sym.
apply Z.eqb_sym.
Qed.

Definition term_leb (x y : term) : bool := match x , y with
  | Var x , Var y => Pos.leb x y
  | Val x , Val y => Z.leb x y
  | Var x,  Val y => false
  | Val x,  Var y => true
  end.

Definition term_ltb (x y : term) : bool := match x , y with
  | Var x , Var y => Pos.ltb x y
  | Val x , Val y => Z.ltb x y
  | Var x,  Val y => false
  | Val x,  Var y => true
  end.

Lemma term_decide_impl : forall (env : environment) (a b : term),
term_decide a b = true -> term_denote env a = term_denote env b.
Proof. intros. apply term_eqb_refl in H. subst a. reflexivity. Qed.

Local Instance term_dec : Decidable :=
{
  decide := term_decide;
  denote := term_denote;
  decide_impl := term_decide_impl
}.

Close Scope Z.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Properties of the power function *)

Require Import Bool NAxioms NSub NParity NZPow.

(** Derived properties of power, specialized on natural numbers *)

Module Type NPowProp
 (Import A : NAxiomsSig')
 (Import B : NSubProp A)
 (Import C : NParityProp A B).

 Module Import Private_NZPow := Nop <+ NZPowProp A A B.

Ltac auto' := trivial; try rewrite <- neq_0_lt_0; auto using le_0_l.
Ltac wrap l := intros; apply l; auto'.

Lemma pow_succ_r' : forall a b, a^(S b) == a * a^b.
Proof. wrap pow_succ_r. Qed.

(** Power and basic constants *)

Lemma pow_0_l : forall a, a~=0 -> 0^a == 0.
Proof. wrap pow_0_l. Qed.

Definition pow_1_r : forall a, a^1 == a
 := pow_1_r.

Lemma pow_1_l : forall a, 1^a == 1.
Proof. wrap pow_1_l. Qed.

Definition pow_2_r : forall a, a^2 == a*a
 := pow_2_r.

(** Power and addition, multiplication *)

Lemma pow_add_r : forall a b c, a^(b+c) == a^b * a^c.
Proof. wrap pow_add_r. Qed.

Lemma pow_mul_l : forall a b c, (a*b)^c == a^c * b^c.
Proof. wrap pow_mul_l. Qed.

Lemma pow_mul_r : forall a b c, a^(b*c) == (a^b)^c.
Proof. wrap pow_mul_r. Qed.

(** Power and nullity *)

Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0.
Proof. intros. apply (pow_eq_0 a b); trivial. auto'. Qed.

Lemma pow_nonzero : forall a b, a~=0 -> a^b ~= 0.
Proof. wrap pow_nonzero. Qed.

Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b~=0 /\ a==0.
Proof.
 intros a b. split.
 rewrite pow_eq_0_iff. intros [H |[H H']].
  generalize (le_0_l b); order. split; order.
 intros (Hb,Ha). rewrite Ha. now apply pow_0_l'.
Qed.

(** Monotonicity *)

Lemma pow_lt_mono_l : forall a b c, c~=0 -> a<b -> a^c < b^c.
Proof. wrap pow_lt_mono_l. Qed.

Lemma pow_le_mono_l : forall a b c, a<=b -> a^c <= b^c.
Proof. wrap pow_le_mono_l. Qed.

Lemma pow_gt_1 : forall a b, 1<a -> b~=0 -> 1<a^b.
Proof. wrap pow_gt_1. Qed.

Lemma pow_lt_mono_r : forall a b c, 1<a -> b<c -> a^b < a^c.
Proof. wrap pow_lt_mono_r. Qed.

(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *)

Lemma pow_le_mono_r : forall a b c, a~=0 -> b<=c -> a^b <= a^c.
Proof. wrap pow_le_mono_r. Qed.

Lemma pow_le_mono : forall a b c d, a~=0 -> a<=c -> b<=d ->
 a^b <= c^d.
Proof. wrap pow_le_mono. Qed.

Definition pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d ->
 a^b < c^d
 := pow_lt_mono.

(** Injectivity *)

Lemma pow_inj_l : forall a b c, c~=0 -> a^c == b^c -> a == b.
Proof. intros; eapply pow_inj_l; eauto; auto'. Qed.

Lemma pow_inj_r : forall a b c, 1<a -> a^b == a^c -> b == c.
Proof. intros; eapply pow_inj_r; eauto; auto'. Qed.

(** Monotonicity results, both ways *)

Lemma pow_lt_mono_l_iff : forall a b c, c~=0 ->
  (a<b <-> a^c < b^c).
Proof. wrap pow_lt_mono_l_iff. Qed.

Lemma pow_le_mono_l_iff : forall a b c, c~=0 ->
  (a<=b <-> a^c <= b^c).
Proof. wrap pow_le_mono_l_iff. Qed.

Lemma pow_lt_mono_r_iff : forall a b c, 1<a ->
  (b<c <-> a^b < a^c).
Proof. wrap pow_lt_mono_r_iff. Qed.

Lemma pow_le_mono_r_iff : forall a b c, 1<a ->
  (b<=c <-> a^b <= a^c).
Proof. wrap pow_le_mono_r_iff. Qed.

(** For any a>1, the a^x function is above the identity function *)

Lemma pow_gt_lin_r : forall a b, 1<a -> b < a^b.
Proof. wrap pow_gt_lin_r. Qed.

(** Someday, we should say something about the full Newton formula.
    In the meantime, we can at least provide some inequalities about
    (a+b)^c.
*)

Lemma pow_add_lower : forall a b c, c~=0 ->
  a^c + b^c <= (a+b)^c.
Proof. wrap pow_add_lower. Qed.

(** This upper bound can also be seen as a convexity proof for x^c :
    image of (a+b)/2 is below the middle of the images of a and b
*)

Lemma pow_add_upper : forall a b c, c~=0 ->
  (a+b)^c <= 2^(pred c) * (a^c + b^c).
Proof. wrap pow_add_upper. Qed.

(** Power and parity *)

Lemma even_pow : forall a b, b~=0 -> even (a^b) = even a.
Proof.
 intros a b Hb. rewrite neq_0_lt_0 in Hb.
 apply lt_ind with (4:=Hb). solve_proper.
 now nzsimpl.
 clear b Hb. intros b Hb IH.
 rewrite pow_succ_r', even_mul, IH. now destruct (even a).
Qed.

Lemma odd_pow : forall a b, b~=0 -> odd (a^b) = odd a.
Proof.
 intros. now rewrite <- !negb_even, even_pow.
Qed.

End NPowProp.


From exercises Require Export language.

(** * Syntactic types for HeapLang *)
(** The inductive type [ty] defines the syntactic types for HeapLang. We make
use of De Bruijn indices to model type-level binding. *)
Inductive ty :=
  | TVar : nat → ty
  | TUnit : ty
  | TBool : ty
  | TInt : ty
  | TProd : ty → ty → ty
  | TSum : ty → ty → ty
  | TArr : ty → ty → ty
  | TForall : ty → ty
  | TExist : ty → ty
  | TRef : ty → ty
  | TRec : ty → ty.

(** To obtain nice notations when writing types for concrete programs, we define
some Coq notations for types. These notations are put in the notation scope
[ty_scope]. We use the [Bind Scope] command to instruct Coq to parse terms of
type [ty] using the notations in [type_scope]. When the type is not clear from
the context, one can write [τ%ty] to force Coq to parse [τ] using the notations
in [type_scope]. This is set up using the [Delimit Scope] command. *)
Declare Scope ty_scope.
Bind Scope ty_scope with ty.
Delimit Scope ty_scope with ty.
Notation "# x" := (TVar x) : ty_scope.
Notation "()" := TUnit : ty_scope.
Infix "*" := TProd : ty_scope.
Infix "+" := TSum : ty_scope.
Infix "→" := TArr : ty_scope.
Notation "∀: τ" := (TForall τ) (at level 100, τ at level 200) : ty_scope.
Notation "∃: τ" := (TExist τ) (at level 100, τ at level 200) : ty_scope.
Notation "'ref' τ" := (TRef τ) (at level 10, τ at next level, right associativity): ty_scope.
Notation "μ: τ" := (TExist τ) (at level 100, τ at level 200) : ty_scope.

(** * Type-level substitution *)
(** Below we define the function [ty_subst x σ τ], which replaces the De Bruijn
index [x] in the type [τ] by the type [σ]. The definition is standard, and makes
use of the lifting function [ty_lift]. *)
Fixpoint ty_lift (n : nat) (τ : ty) : ty :=
  match τ with
  | TVar y => TVar (if decide (y < n) then y else S y)%nat
  | TUnit => TUnit
  | TBool => TBool
  | TInt => TInt
  | TProd τ1 τ2 => TProd (ty_lift n τ1) (ty_lift n τ2)
  | TSum τ1 τ2 => TSum (ty_lift n τ1) (ty_lift n τ2)
  | TArr τ1 τ2 => TArr (ty_lift n τ1) (ty_lift n τ2)
  | TForall τ => TForall (ty_lift (S n) τ)
  | TExist τ => TExist (ty_lift (S n) τ)
  | TRef τ => TRef (ty_lift n τ)
  | TRec τ => TRec (ty_lift (S n) τ)
  end.

Fixpoint ty_subst (x : nat) (σ : ty) (τ : ty) : ty :=
  match τ with
  | TVar y => if decide (y < x) then TVar y
              else if decide (y = x) then σ else TVar (pred y)
  | TUnit => TUnit
  | TBool => TBool
  | TInt => TInt
  | TProd τ1 τ2 => TProd (ty_subst x σ τ1) (ty_subst x σ τ2)
  | TSum τ1 τ2 => TSum (ty_subst x σ τ1) (ty_subst x σ τ2)
  | TArr τ1 τ2 => TArr (ty_subst x σ τ1) (ty_subst x σ τ2)
  | TForall τ => TForall (ty_subst (S x) (ty_lift 0 σ) τ)
  | TExist τ => TExist (ty_subst (S x) (ty_lift 0 σ) τ)
  | TRef τ => TRef (ty_subst x σ τ)
  | TRec τ => TRec (ty_subst (S x) (ty_lift 0 σ) τ)
  end.


Require Import Reals.

Open Scope R_scope.

Definition Real := R.

(* function parameter *)
Variable s : Real.

(* constant *)
Parameter Kt Bm Ke : Real.

(* variables *)
Parameter Rm Lm Jm : Real.

(* functions from s to real. *)
Variables Um Im Om Tm : Real -> Real.

Definition tm1 := (Um s) - Rm * (Im s) - Lm * s * (Im s) - Ke * (Om s).
Definition tm2 := Kt * (Im s) - Jm * s * (Om s) - Bm * (Om s) - (Tm s).
Definition tm3 := (Tm s) * (Lm *s + Rm).
Definition tm4 := (Um s) * Kt - Kt * Ke * (Om s) - (Lm * s + Rm) * (Jm * s + Bm) * (Om s).

(* assumptions of this deduction. *)
Axiom e1 : tm1 = 0.
Axiom e2 : tm2 = 0.
Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1.
Axiom e3 : (Lm *s + Rm) <> 0.

Definition tm5 :=  ((Um s) - Rm * (Im s) - (Lm * s) * (Im s)).

Lemma eq0_eq : forall y z, y-z = 0 -> y = z.
intros.
apply sym_eq.
apply Rminus_diag_uniq_sym.
assumption.
Qed.

(* move Ke * (Om s) in tm1 to the  right of  = *)
Lemma tm5_eq : tm5  = Ke * (Om s).
apply eq0_eq.
apply e1.
Qed.

Definition tm6 :=  ((Um s) - (Rm + Lm * s) * (Im s)).

Lemma  tm6_eq_tm5 : tm6 = tm5.
unfold tm5; unfold tm6.
ring.
Qed.

Lemma tm6_eq : tm6 = Ke * (Om s).
rewrite tm6_eq_tm5.
apply tm5_eq.
Qed.

Lemma tm5_eq0 : tm5 - Ke * (Om s) = 0.
apply e1.
Qed.

Definition tm7:= (Rm + Lm * s) * (Im s).

Definition tm8:= (Um s)-Ke * (Om s).

Lemma  tm8_tm7_eq : tm8 - tm7 = tm5 - Ke * (Om s).
unfold tm7; unfold tm8; unfold tm5.
ring.
Qed.

Lemma tm8_eq_tm7 : tm8 = tm7.
apply eq0_eq.
rewrite tm8_tm7_eq.
apply tm5_eq0.
Qed.

Definition tm9 := tm7 * Kt.
Definition tm10 := tm8 * Kt.

Lemma tm9_eq_tm10 : tm10 = tm9.
unfold tm9; unfold tm10.
rewrite tm8_eq_tm7.
ring.
Qed.

Definition tm11:= (Jm * s + Bm) * (Om s) + (Tm s).

Definition tm12:= Kt * (Im s).

Lemma tm11_tm12_eq : tm12 - tm11 = tm2.
unfold tm11; unfold tm12; unfold tm2.
ring.
Qed.

Lemma tm11_eq_tm12 : tm12 = tm11.
apply eq0_eq.
rewrite tm11_tm12_eq.
apply e2.
Qed.

Definition tm13:= tm11*(Rm + Lm * s).

Definition tm14:= tm12*(Rm + Lm * s).

Lemma tm13_eq_tm14 : tm13 = tm14.
unfold tm13; unfold tm14.
rewrite tm11_eq_tm12.
ring.
Qed.

Lemma tm13_eq_tm9 : tm13 = tm9.
rewrite tm13_eq_tm14.
unfold tm14; unfold tm9.
unfold tm12; unfold tm7.
ring.
Qed.

Lemma tm13_eq_tm10 : tm13 = tm10.
rewrite tm13_eq_tm9.
apply sym_eq.
apply tm9_eq_tm10.
Qed.

Lemma tm3_tm13_eq0 : tm3 = tm13 - (Jm * s + Bm) * (Om s) * (Rm + Lm * s).
unfold tm3; unfold tm13.
unfold tm11.
ring.
Qed.

Lemma tm4_tm10_eq0 : tm4 = tm10 - (Jm * s + Bm) * (Om s) * (Rm + Lm * s).
unfold tm4; unfold tm10.
unfold tm8.
ring.
Qed.

Lemma tm3_eq_tm4 : tm3 = tm4.
rewrite tm3_tm13_eq0.
rewrite tm4_tm10_eq0.
rewrite tm13_eq_tm10.
ring.
Qed.

Lemma tm4_eq_tm3 : tm4 = tm3.
apply sym_eq.
apply tm3_eq_tm4.
Qed.

Lemma l2 : (Lm *s + Rm) * / (Lm * s + Rm)  = 1.
apply Rinv_r.
apply e3.
Qed.

Lemma l3 : (Lm * s + Rm) * (/ (Lm * s + Rm) * tm4) = (Lm * s + Rm) * / (Lm * s + Rm) * tm4.
apply sym_eq.
apply Rmult_assoc.
Qed.

Theorem final_result : (Lm *s + Rm) <> 0 -> Tm s = / (Lm *s + Rm) * tm4.
apply Rmult_eq_reg_l.
rewrite l3.
rewrite l2.
rewrite tm4_eq_tm3.
unfold tm3.
ring.
Qed.


Require Import Iron.Data.List.Base.
Require Import Iron.Data.List.Map.
Require Import Omega.

Lemma match_option
 : forall {A} {B} (f: A -> B) (xs: list A) ix y
 , f (match get ix xs         with | Some x => x | None  => y   end)
 =   (match get ix (map f xs) with | Some x => x | None  => f y end).
Proof.
 intros.
 remember (get ix xs) as Get.
 destruct Get.
  symmetry in HeqGet.
  apply (get_map f) in HeqGet.
  rewrite HeqGet. auto.

  remember (get ix (map f xs)) as X.
  destruct X.
   symmetry in HeqX.   eapply get_length_more in HeqX.
   symmetry in HeqGet. eapply get_none_length in HeqGet.
   rewrite map_length in HeqX. exfalso. omega.
   auto.
Qed.


Require Import QArith.
Require Import QArith.Qcanon.

From F4 Require Export geometry.

Open Scope Qc_scope.
Open Scope program_scope.

Inductive ViewPort :=
  | viewPort : forall (e : Point) (ls : LineSeg), isAffine e -> ~isPointOnLine e (lineFromLineSeg ls) -> ViewPort.

Definition flipViewPort (v : ViewPort) : ViewPort.
refine (
  match v with
  | viewPort e l evAffE evV => viewPort e (flipLineSeg l) evAffE _
  end
).
  unfold not. intros contra. unfold not in evV. apply evV.
  apply (equal_lines_contain_same_points _ _ e (flipped_line_seg_same_line l) contra).
Defined.

Definition vpEye (v : ViewPort) :=
  match v with
  | viewPort e _ _ _ => e
  end.

Definition vpVertexA (v : ViewPort) :=
  match v with
  | viewPort _ (lineSeg a b _ _ _) _ _ => a
  end.

Definition vpVertexB := vpVertexA @ flipViewPort.

Definition vpBackLine (v : ViewPort) : Line :=
  match v with
  | viewPort _ lv _ _ => lineFromLineSeg lv
  end.

Definition viewPortEdgeA (v : ViewPort) : LineSeg.
refine (
  lineSeg (vpEye v) (vpVertexA v) _ _ _
); destruct v as [e [a b evNe evAffA evAffB] evAffE evV]; unfold vpEye; unfold vpVertexA.
  - unfold not. intros H. unfold lineFromLineSeg in evV. unfold not in evV. apply evV.
    apply equal_points_on_line with (p:=a).
    + rewrite -> eqp_symmetric. assumption.
    + destruct (end_points_on_line a b evNe) as [Ha Hb]. assumption.
  - assumption.
  - assumption.
Defined.

Definition viewPortEdgeB := viewPortEdgeA @ flipViewPort.

Definition negT (t : Triple) :=
  match t with
  | triple x y z => triple (-x) (-y) (-z)
  end.

Definition zPosify (p : Point) : Point.
refine (
  match p as p' return (p = p' -> _) with
  | point t ev =>
    let q := point (negT t) _ in
    match t with
    | triple _ _ z =>
      fun H => if Qc_lt_bool z 0 then q else p
    end
  end (eq_refl p)).
  destruct t as [x y z]. simpl in ev. simpl. repeat (rewrite <- Qc_non_vanishing_sign). assumption.
Defined.

(* TODO (maybe) kill zPosify and negT and just implement the below
  by exclusive or with boolean signs as needed *)
Definition isPointInsideViewPort_b (p : Point) (v : ViewPort) : bool :=
  match v with
  | viewPort e (lineSeg a b _ _ _) _ _ =>
    let p' := zPosify p in
    let e' := zPosify e in
    let a' := zPosify a in
    let b' := zPosify b in
    let sv   := signum (det3pt e' a' b') in
    let spab := signum (det3pt p' a' b') in
    let sepb := signum (det3pt e' p' b') in
    let seap := signum (det3pt e' a' p') in
    let sameSide_ab := Qc_eq_bool sv spab in
    let sameSide_be := Qc_eq_bool sv sepb in
    let sameSide_ea := Qc_eq_bool sv seap in
      sameSide_ab && sameSide_be && sameSide_ea
  end.

Definition isPointInsideViewPort (p : Point) (v : ViewPort) :=
  isPointInsideViewPort_b p v = true.

Lemma flipped_viewport_same_inside : forall (p : Point) (v : ViewPort),
  isPointInsideViewPort p v -> isPointInsideViewPort p (flipViewPort v).
Proof.
  intros p [e [a b evAB evAffA evAffB] evAffE evV].
  unfold flipViewPort. unfold flipLineSeg. unfold isPointInsideViewPort. unfold isPointInsideViewPort_b.
  repeat (rewrite andb_true_iff). repeat (rewrite Qc_eq_bool_correct'''). intros [[He Ha] Hb]. repeat split; [
    repeat (rewrite (det3pt_permute_sign _ (zPosify b) (zPosify a))) |
    repeat (rewrite (det3pt_permute_sign (zPosify e) _ (zPosify a))) |
    repeat (rewrite (det3pt_permute_sign (zPosify e) (zPosify b) _)) ];
  rewrite <- signum_minus'; assumption.
Defined.

Lemma zPosify_det3pt' : forall p q r : Point,
  det3pt (zPosify p) q r = 0 <-> det3pt p q r = 0.
Proof.
  intros [[x1 y1 z1] ev1] [[x2 y2 z2] ev2] [[x3 y3 z3] ev3].
  unfold zPosify. destruct (Qc_lt_bool z1 0).
  - unfold negT. unfold det3pt. unfold det3.
    assert (H : forall a b c u v w : Qc, (-a)*u + (-b)*v + (-c)*w = -(a*u + b*v + c*w)). { intros. ring. }
    rewrite -> H. apply Qc_opp_x_zero.
  - apply iff_refl.
Defined.

Lemma zPosify_det3pt : forall p q r : Point,
  det3pt (zPosify p) (zPosify q) (zPosify r) = 0 <-> det3pt p q r = 0.
Proof.
  intros p q r.
  rewrite -> zPosify_det3pt'.
  rewrite det3pt_permute. rewrite -> zPosify_det3pt'.
  rewrite det3pt_permute. rewrite -> zPosify_det3pt'.
  rewrite det3pt_permute.
  apply iff_refl.
Defined.

Lemma inside_viewport_not_on_edge_a : forall (p : Point) (v : ViewPort),
  isPointInsideViewPort p v -> ~isPointOnLine p (lineFromLineSeg (viewPortEdgeA v)).
Proof.
  unfold not. intros p [e [a b evL evAffA evAffB] evAffE evV] evInside evOnEdge.
  unfold not in evV. apply evV.
  unfold lineFromLineSeg.
  apply point_on_line_seg_det.
  assert (H : det3pt e a p = 0). {
    unfold viewPortEdgeA in evOnEdge. unfold vpEye in evOnEdge. unfold vpVertexA in evOnEdge.
    unfold lineFromLineSeg in evOnEdge.
    rewrite <- point_on_line_seg_det in evOnEdge. rewrite <- det3pt_permute in evOnEdge.
    assumption.
  }
  unfold isPointInsideViewPort in evInside. unfold isPointInsideViewPort_b in evInside.
  apply andb_prop in evInside. destruct evInside as [_ evInside'].
  rewrite <- zPosify_det3pt. rewrite <- zPosify_det3pt in H.
  rewrite -> H in evInside'. rewrite signum_zero in evInside'.
  rewrite -> Qc_eq_bool_correct''' in evInside'.
  apply signum_zero_is_zero. apply symmetry in evInside'.
  assumption.
Defined.

Lemma inside_viewport_not_eye : forall (p : Point) (v : ViewPort),
  isPointInsideViewPort p v -> ~eqp (vpEye v) p.
Proof.
  unfold not. intros p v evInside evEq.
  apply (inside_viewport_not_on_edge_a _ _ evInside).
  apply (equal_points_on_line _ _ _ evEq).
  apply end_points_on_line.
Defined.

Definition viewPortClippingLine (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v) : Line :=
  pointPairLine (pointPair (vpEye v) p (inside_viewport_not_eye p v evInside)).

Lemma viewport_clipping_line_contains_eye : forall (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v),
  isPointOnLine (vpEye v) (viewPortClippingLine p v evInside).
Proof.
  intros p v evInside. unfold viewPortClippingLine.
  destruct (end_points_on_line (vpEye v) p (inside_viewport_not_eye p v evInside)) as [He Hp].
  assumption.
Defined.

Definition viewPortClippingPoint (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v) : Point.
refine (
    let lc := viewPortClippingLine p v evInside in
    let lv := vpBackLine v in
      linePairIntersection (linePair lv lc _)
).
  rewrite -> eql_symmetric. apply (line_pair_distinct_point (vpEye v)).
  - apply viewport_clipping_line_contains_eye.
  - destruct v as [e ls eAff evV]. unfold vpEye. unfold vpBackLine in lv. assumption.
Defined.

Lemma vp_clipping_point_not_eye : forall (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v),
  ~eqp (viewPortClippingPoint p v evInside) (vpEye v).
Proof.
  unfold not. intros p v evInside contra.
  assert (H : isPointOnLine (viewPortClippingPoint p v evInside) (vpBackLine v)). { apply intersection_on_lines. }
  apply (equal_points_on_line _ _ _ contra) in H.
  destruct v as [e l evAffE evV].
  contradiction.
Defined.

Lemma vp_clipping_point_not_vertex_a : forall (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v),
  ~eqp (vpVertexA v) (viewPortClippingPoint p v evInside).
Proof.
  unfold not. intros p v evInside contra.
  assert (H : eql (viewPortClippingLine p v evInside) (lineFromLineSeg (viewPortEdgeA v))). {
    apply two_points_characterise_line with (p:=(vpEye v)) (q:=(viewPortClippingPoint p v evInside)).
    - rewrite eqp_symmetric. apply vp_clipping_point_not_eye.
    - apply end_points_on_line.
    - apply intersection_on_lines.
    - apply end_points_on_line.
    - apply (equal_points_on_line _ _ _ contra). apply end_points_on_line.
  }
  assert (H' : isPointOnLine p (lineFromLineSeg (viewPortEdgeA v))). {
    apply (equal_lines_contain_same_points _ _ _ H).
    apply end_points_on_line.
  }
  apply (inside_viewport_not_on_edge_a _ _ evInside H').
Defined.

Lemma clipping_point_affine : forall (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v),
  isAffine (viewPortClippingPoint p v evInside).
Proof. (* TODO *) Admitted.

Definition vpLineSegClipA (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v) : LineSeg.
refine (
  lineSeg (vpVertexA v) (viewPortClippingPoint p v evInside) (vp_clipping_point_not_vertex_a p v evInside) _ _
).
  - destruct v as [e [a b evABDistinct evAffA evAffB] eAff evV]. assumption.
  - apply clipping_point_affine.
Defined.

Lemma vp_clipping_point_gives_viewport_a : forall (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v),
  ~isPointOnLine (vpEye v) (lineFromLineSeg (vpLineSegClipA p v evInside)).
Proof.
  intros p v evInside.
  assert (H : eql (lineFromLineSeg (vpLineSegClipA p v evInside)) (vpBackLine v)). {
    apply (two_points_characterise_line _ _ (vpVertexA v) (viewPortClippingPoint p v evInside) (vp_clipping_point_not_vertex_a _ _ _)).
    - unfold vpLineSegClipA. apply end_points_on_line.
    - unfold vpLineSegClipA. apply end_points_on_line.
    - destruct v as [e [a b evAB evA evB] evE evV]. apply end_points_on_line.
    - apply intersection_on_lines.
  }
  destruct v as [e ls evAffE evV].
  simpl in H. simpl.
  unfold not. intros contra. unfold not in evV. apply evV.
  apply (equal_lines_contain_same_points _ _ _ H). apply contra.
Defined.

Definition vpClipToSideA (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v) : ViewPort.
refine (
  viewPort (vpEye v) (vpLineSegClipA p v evInside) _ (vp_clipping_point_gives_viewport_a p v evInside)
).
  destruct v. unfold vpEye. assumption.
Defined.

Definition vpClipToSideB (p : Point) (v : ViewPort) (evInside : isPointInsideViewPort p v) : ViewPort :=
  vpClipToSideA p (flipViewPort v) (flipped_viewport_same_inside p v evInside).


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* Certified Undecidability of Intuitionistic Linear Logic via Binary Stack Machines and Minsky Machines. Yannick Forster and Dominique Larchey-Wendling. CPP '19. http://uds-psl.github.io/ill-undecidability/ *)

Require Import List Permutation.

Set Implicit Arguments.

(* * Intuionistic Linear Logic *)

Local Infix "~p" := (@Permutation _) (at level 70).

(* We consider four fragments of ILL:
    - the (!,-o,&) fragment with or without cut
    - full fragment with or without cut
*)

Notation ill_vars := nat.

Inductive ill_connective := ill_with | ill_limp | ill_times | ill_plus.
Inductive ill_constant := ill_1 | ill_bot | ill_top.

Inductive ill_form : Set :=
  | ill_var  : ill_vars -> ill_form
  | ill_cst  : ill_constant -> ill_form
  | ill_ban  : ill_form -> ill_form
  | ill_bin  : ill_connective -> ill_form -> ill_form -> ill_form.

(* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  !   ‼  ∅  ⊢ *)

Notation "⟙" := (ill_cst ill_top).
Notation "⟘" := (ill_cst ill_bot).
Notation "𝟙" := (ill_cst ill_1).

Infix "&" := (ill_bin ill_with) (at level 50).
Infix "⊗" := (ill_bin ill_times) (at level 50).
Infix "⊕" := (ill_bin ill_plus) (at level 50).
Infix "⊸" := (ill_bin ill_limp) (at level 51, right associativity).

Notation "'!' x" := (ill_ban x) (at level 52).

Notation "£" := ill_var.

Notation "‼ x" := (map ill_ban x) (at level 60).

Notation "∅" := nil (only parsing).

Reserved Notation "l '⊢' x" (at level 70, no associativity).

Section S_ill_restr_without_cut.

  (* These are the SILL rules in the CPP'19 paper w/o the cut *)

  Inductive S_ill_restr : list ill_form -> ill_form -> Prop :=

    | in_ill1_ax     : forall A,                        A::∅ ⊢ A

    | in_ill1_perm   : forall Γ Δ A,              Γ ~p Δ     ->   Γ ⊢ A
                                           (*-----------------------------*)
                                        ->                 Δ ⊢ A

    | in_ill1_limp_l : forall Γ Δ A B C,         Γ ⊢ A      ->   B::Δ ⊢ C
                                           (*-----------------------------*)
                                      ->           A ⊸ B::Γ++Δ ⊢ C

    | in_ill1_limp_r : forall Γ A B,                  A::Γ ⊢ B
                                           (*-----------------------------*)
                                        ->            Γ ⊢ A ⊸ B

    | in_ill1_with_l1 : forall Γ A B C,               A::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A&B::Γ ⊢ C

    | in_ill1_with_l2 : forall Γ A B C,               B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A&B::Γ ⊢ C

    | in_ill1_with_r : forall Γ A B,            Γ ⊢ A     ->   Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A&B

    | in_ill1_bang_l : forall Γ A B,                   A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              !A::Γ ⊢ B

    | in_ill1_bang_r : forall Γ A,                    ‼Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              ‼Γ ⊢ !A

    | in_ill1_weak : forall Γ A B,                       Γ ⊢ B
                                           (*-----------------------------*)
                                      ->             !A::Γ ⊢ B

    | in_ill1_cntr : forall Γ A B,                 !A::!A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->               !A::Γ ⊢ B

  where "l ⊢ x" := (S_ill_restr l x).

End S_ill_restr_without_cut.

Section S_ill_restr_with_cut.

  (* These are the SILL rules in the CPP'19 paper including the cut rule *)

  Inductive S_ill_restr_wc : list ill_form -> ill_form -> Prop :=

    | in_ill2_ax     : forall A,                        A::∅ ⊢ A

    | in_ill2_cut : forall Γ Δ A B,              Γ ⊢ A    ->   A::Δ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ++Δ ⊢ B

    | in_ill2_perm   : forall Γ Δ A,              Γ ~p Δ     ->   Γ ⊢ A
                                           (*-----------------------------*)
                                        ->                 Δ ⊢ A

    | in_ill2_limp_l : forall Γ Δ A B C,         Γ ⊢ A      ->   B::Δ ⊢ C
                                           (*-----------------------------*)
                                      ->           A ⊸ B::Γ++Δ ⊢ C

    | in_ill2_limp_r : forall Γ A B,                  A::Γ ⊢ B
                                           (*-----------------------------*)
                                        ->            Γ ⊢ A ⊸ B

    | in_ill2_with_l1 : forall Γ A B C,               A::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A&B::Γ ⊢ C

    | in_ill2_with_l2 : forall Γ A B C,               B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A&B::Γ ⊢ C

    | in_ill2_with_r : forall Γ A B,            Γ ⊢ A     ->   Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A&B

    | in_ill2_bang_l : forall Γ A B,                   A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              !A::Γ ⊢ B

    | in_ill2_bang_r : forall Γ A,                    ‼Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              ‼Γ ⊢ !A

    | in_ill2_weak : forall Γ A B,                       Γ ⊢ B
                                           (*-----------------------------*)
                                      ->             !A::Γ ⊢ B

    | in_ill2_cntr : forall Γ A B,                 !A::!A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->               !A::Γ ⊢ B

  where "l ⊢ x" := (S_ill_restr_wc l x).

End S_ill_restr_with_cut.

Section S_ill_without_cut.

  (* These are the rules for the whole ILL, without cut *)

  Inductive S_ill : list ill_form -> ill_form -> Prop :=

    | in_ill3_ax     : forall A,                        A::∅ ⊢ A

    | in_ill3_perm   : forall Γ Δ A,              Γ ~p Δ     ->   Γ ⊢ A
                                           (*-----------------------------*)
                                        ->                 Δ ⊢ A

    | in_ill3_limp_l : forall Γ Δ A B C,         Γ ⊢ A      ->   B::Δ ⊢ C
                                           (*-----------------------------*)
                                      ->           A ⊸ B::Γ++Δ ⊢ C

    | in_ill3_limp_r : forall Γ A B,                  A::Γ ⊢ B
                                           (*-----------------------------*)
                                        ->            Γ ⊢ A ⊸ B

    | in_ill3_with_l1 : forall Γ A B C,               A::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A&B::Γ ⊢ C

    | in_ill3_with_l2 : forall Γ A B C,               B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A&B::Γ ⊢ C

    | in_ill3_with_r : forall Γ A B,            Γ ⊢ A     ->   Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A&B

    | in_ill3_bang_l : forall Γ A B,                   A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              !A::Γ ⊢ B

    | in_ill3_bang_r : forall Γ A,                    ‼Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              ‼Γ ⊢ !A

    | in_ill3_weak : forall Γ A B,                       Γ ⊢ B
                                           (*-----------------------------*)
                                      ->             !A::Γ ⊢ B

    | in_ill3_cntr : forall Γ A B,                 !A::!A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->               !A::Γ ⊢ B

    | in_ill3_times_l : forall Γ A B C,            A::B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->            A⊗B::Γ ⊢ C

    | in_ill3_times_r : forall Γ Δ A B,          Γ ⊢ A    ->   Δ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ++Δ ⊢ A⊗B

    | in_ill3_plus_l :  forall Γ A B C,         A::Γ ⊢ C  ->  B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->            A⊕B::Γ ⊢ C

    | in_ill3_plus_r1 : forall Γ A B,                 Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A⊕B

    | in_ill3_plus_r2 : forall Γ A B,                 Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A⊕B

    | in_ill3_bot_l : forall Γ A,                  ⟘::Γ ⊢ A

    | in_ill3_top_r : forall Γ,                       Γ ⊢ ⟙

    | in_ill3_unit_l : forall Γ A,                    Γ ⊢ A
                                           (*-----------------------------*)
                                      ->           𝟙::Γ ⊢ A

    | in_ill3_unit_r :                                ∅ ⊢ 𝟙

  where "l ⊢ x" := (S_ill l x).

End S_ill_without_cut.

Section S_ill_with_cut.

  (* These are the rules for the whole ILL, without cut *)

  Inductive S_ill_wc : list ill_form -> ill_form -> Prop :=

    | in_ill4_ax     : forall A,                        A::∅ ⊢ A

    | in_ill4_cut : forall Γ Δ A B,              Γ ⊢ A    ->   A::Δ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ++Δ ⊢ B

    | in_ill4_perm   : forall Γ Δ A,              Γ ~p Δ     ->   Γ ⊢ A
                                           (*-----------------------------*)
                                        ->                 Δ ⊢ A

    | in_ill4_limp_l : forall Γ Δ A B C,         Γ ⊢ A      ->   B::Δ ⊢ C
                                           (*-----------------------------*)
                                      ->           A ⊸ B::Γ++Δ ⊢ C

    | in_ill4_limp_r : forall Γ A B,                  A::Γ ⊢ B
                                           (*-----------------------------*)
                                        ->            Γ ⊢ A ⊸ B

    | in_ill4_with_l1 : forall Γ A B C,               A::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A&B::Γ ⊢ C

    | in_ill4_with_l2 : forall Γ A B C,               B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->           A&B::Γ ⊢ C

    | in_ill4_with_r : forall Γ A B,            Γ ⊢ A     ->   Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A&B

    | in_ill4_bang_l : forall Γ A B,                   A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              !A::Γ ⊢ B

    | in_ill4_bang_r : forall Γ A,                    ‼Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              ‼Γ ⊢ !A

    | in_ill4_weak : forall Γ A B,                       Γ ⊢ B
                                           (*-----------------------------*)
                                      ->             !A::Γ ⊢ B

    | in_ill4_cntr : forall Γ A B,                 !A::!A::Γ ⊢ B
                                           (*-----------------------------*)
                                      ->               !A::Γ ⊢ B

    | in_ill4_times_l : forall Γ A B C,            A::B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->            A⊗B::Γ ⊢ C

    | in_ill4_times_r : forall Γ Δ A B,          Γ ⊢ A    ->   Δ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ++Δ ⊢ A⊗B

    | in_ill4_plus_l :  forall Γ A B C,         A::Γ ⊢ C  ->  B::Γ ⊢ C
                                           (*-----------------------------*)
                                      ->            A⊕B::Γ ⊢ C

    | in_ill4_plus_r1 : forall Γ A B,                 Γ ⊢ A
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A⊕B

    | in_ill4_plus_r2 : forall Γ A B,                 Γ ⊢ B
                                           (*-----------------------------*)
                                      ->              Γ ⊢ A⊕B

    | in_ill4_bot_l : forall Γ A,                  ⟘::Γ ⊢ A

    | in_ill4_top_r : forall Γ,                       Γ ⊢ ⟙

    | in_ill4_unit_l : forall Γ A,                    Γ ⊢ A
                                           (*-----------------------------*)
                                      ->           𝟙::Γ ⊢ A

    | in_ill4_unit_r :                                ∅ ⊢ 𝟙

  where "l ⊢ x" := (S_ill_wc l x).

End S_ill_with_cut.

Definition rILL_cf_PROVABILITY (S : _*_) := let (Γ,A) := S in S_ill_restr Γ A.
Definition rILL_PROVABILITY (S : _*_) := let (Γ,A) := S in S_ill_restr_wc Γ A.

Definition ILL_cf_PROVABILITY (S : _*_) := let (Γ,A) := S in S_ill Γ A.
Definition ILL_PROVABILITY (S : _*_) := let (Γ,A) := S in S_ill_wc Γ A.


Require Export Arith.
Require Export ArithRing.
Require Export Lia.
Require Export Compare_dec.
Require Export Wf_nat.

Definition div4_spec:
 forall (n : nat),  ({q : nat & {r : nat | n = 4 * q + r /\ r < 4}}).
refine (fix
        div4_spec (n : nat) : {q : nat & {r : nat | n = 4 * q + r /\ r < 4}} :=
           match n return {q : nat & {r : nat | n = 4 * q + r /\ r < 4}} with
              S (S (S (S x'))) =>
                match div4_spec x' with existT _ q' (exist _ r' H) => _ end
             | _ => _
           end); clear div4_spec.
- exists 0, 0; lia.
- exists 0, 1; lia.
- exists 0, 2; lia.
- exists 0,  3; lia.
- exists (S q'), r'; lia.
Qed.

Definition sqrt_nat_F:
 forall n,
 (forall y,
  y < n ->  ({s : nat & {r : nat | y = s * s + r /\ y < (s + 1) * (s + 1)}})) ->
  ({s : nat & {r : nat | n = s * s + r /\ n < (s + 1) * (s + 1)}}).
refine (fun n sqrt_nat =>
           match div4_spec n with
             existT _ 0 (exist _ 0 (conj Heq _)) => _
            | existT _ 0 (exist _ (S r') (conj Heq Hle)) => _
            | existT _ (S q') (exist _ r' (conj Heq Hle)) => _
           end).
- clear sqrt_nat;exists 0, 0; lia.
- exists 1, r';rewrite Heq; split.
  + ring.
  + lia.
 - assert (Hlt: S q' < n) by lia.
   destruct (sqrt_nat (S q') Hlt) as [s' [r'' [Heq' Hlt']]].
   case (le_lt_dec (4 * s' + 1) (4 * r'' + r')).
   + intros Hle'';
     exists (2 * s' + 1), ((4 * r'' + r') - (4 * s' + 1)).
    rewrite Heq,  Heq'; split.
    * replace ((2 * s' + 1) * (2 * s' + 1) + ((4 * r'' + r') - (4 * s' + 1)))
     with (4 * (s' * s') + ((4 * s' + 1) + ((4 * r'' + r') - (4 * s' + 1)))).
     rewrite le_plus_minus_r; [ring | assumption].
     ring.
    * replace (4 * (s' * s' + r'') + r') with ((4 * s') * s' + (4 * r'' + r')).
      replace (((2 * s' + 1) + 1) * ((2 * s' + 1) + 1))
      with ((4 * s') * s' + (8 * s' + 4)).
      apply plus_lt_compat_l.
      assert (H: r'' < 2 * s' + 1).
      { apply plus_lt_reg_l with (s' * s').
        rewrite <- Heq'.
        replace (s' * s' + (2 * s' + 1)) with ((s' + 1) * (s' + 1)).
        assumption.
        ring.
      }
      lia.
      ring.
      ring.
   + intros Hlt''; exists (2 * s'),  (4 * r'' + r');
     rewrite Heq,  Heq'.
     split.
     * ring.
     * replace (4 * (s' * s' + r'') + r') with ((4 * s') * s' + (4 * r'' + r')).
       replace ((2 * s' + 1) * (2 * s' + 1)) with ((4 * s') * s' + (4 * s' + 1)).
       lia.
       ring.
       ring.
Defined.

Definition sqrt_nat' :
  forall n,  ({s : nat & {r : nat | n = s * s + r /\ n < (s + 1) * (s + 1)}}) :=
   well_founded_induction
    lt_wf
    (fun n => {s : nat & {r : nat | n = s * s + r /\ n < (s + 1) * (s + 1)}})
    sqrt_nat_F.


Load Common.

Require Import FormulaFacts.
Require Import ListFacts.

Require Import UserTactics.
Require Import MiscFacts.

Inductive derivation (Γ: list formula) : formula → Prop :=
  | ax : ∀ (s: formula), In s Γ → derivation Γ s
  | elim_arr : ∀ (s t : formula), derivation Γ (Formula.arr s t) → derivation Γ s → derivation Γ t
  | intro_arr : ∀ (s t : formula), derivation (s :: Γ) t → derivation Γ (Formula.arr s t)
  | elim_quant : ∀ (s t : formula), derivation Γ s → contains s t → derivation Γ t
  | intro_quant : ∀ (s: formula),
   (forall (a: label), derivation Γ (instantiate (atom a) 0 s)) → derivation Γ (Formula.quant s).

Inductive normal_derivation : nat → list formula → formula → Prop :=
(*(s :: Γ) in derive_arr not a problem, context permutation is admissible*)
  | derive_arr : ∀ (n : nat) (Γ: list formula) (s t: formula),
    normal_derivation n (s :: Γ) t → normal_derivation (S n) Γ (Formula.arr s t)
  | derive_quant : ∀ (n : nat) (Γ: list formula) (s: formula),
   (forall (a: label), normal_derivation n Γ (instantiate (atom a) 0 s) ) → normal_derivation (S n) Γ (Formula.quant s)
  | derive_atom : ∀ (n : nat) (Γ: list formula) (a: label) (s: formula) (params: list formula),
      In s Γ → Formula.chain s a params → (Forall (normal_derivation n Γ) (params)) → normal_derivation (S n) Γ (Formula.atom a).

Axiom normal_derivation_completeness : forall (Γ: list formula) (s: formula), derivation Γ s → exists (n : nat), normal_derivation n Γ s.

(*tries to solve derivation Γ s automatically*)
Ltac derivation_rule := first
  [ apply ax => //; by list_element
  | ( do ? (apply intro_quant => //=; intro);
      do ? (apply intro_arr);
      apply ax => //; by list_element)
  (*| match goal with | [H : In ?s ?Γ |- derivation _ ?s] => apply ax; list_inclusion end (*slow, unnecessary*)*)
  | (by (eauto using derivation))].

Theorem normal_derivation_soundness : forall (n : nat) (Γ: list formula) (s: formula), normal_derivation n Γ s → derivation Γ s.
Proof.
elim; intros *.

(*base case n = 0*)
inversion.

move => IH Γ *.
gimme normal_derivation; inversion; try derivation_rule.

(*atom case*)
gimme In; move /ax.
gimme Forall;
gimme chain; elim.

(*zero step chain*) derivation_rule.
(*multistep chain*) move => ? ? t u *.
decompose_Forall. derivation_rule.
Qed.

(*inversion lemmas*)
Lemma inv_arr : forall (Γ : list formula) (s t : formula),
  derivation Γ (arr s t) -> derivation (s :: Γ) t.
Proof.
intros *.
move /normal_derivation_completeness => [? H].
inversion_clear H.
apply: normal_derivation_soundness; eassumption.
Qed.

Lemma inv_atom : forall (Γ : list formula) (a : label), derivation Γ (atom a) ->
  exists (s : formula) (params : list formula), In s Γ /\ chain s a params /\ (Forall (derivation Γ) (params)).
Proof.
intros *.
move /normal_derivation_completeness => [? H].
inversion_clear H.
match goal with | [H : Forall _ _ |- _] => eapply Forall_impl in H; first last end.
intros.
eapply normal_derivation_soundness. eassumption.
exists s, params. auto.
Qed.

Lemma inv_normal_quant : forall (n : nat) (Γ: list formula) (s : formula), normal_derivation n Γ (quant s) ->
  exists (m : nat), n = S m /\ (forall (a: label), normal_derivation m Γ (instantiate (atom a) 0 s)).
Proof.
intros * => H.
inversion_clear H.
eexists; split; [reflexivity | assumption].
Qed.

Lemma inv_quant : forall (Γ: list formula) (s : formula), derivation Γ (quant s) ->
  (forall (a: label), derivation Γ (instantiate (atom a) 0 s)).
Proof.
intros *.
move /normal_derivation_completeness => [n HD].
move /inv_normal_quant : HD => [m [? ?]].
eauto using normal_derivation_soundness.
Qed.

Lemma inv_normal_arr : forall (n : nat) (Γ: list formula) (s t : formula), normal_derivation n Γ (arr s t) ->
  exists (m : nat), n = S m /\ normal_derivation m (s :: Γ) t.
Proof.
intros * => H.
inversion_clear H.
eexists; split; [reflexivity | assumption].
Qed.

(*decomposition tactics*)
Ltac decompose_normal_derivation :=
  do ? (
  lazymatch goal with
  | [H : Forall _ (_ :: _) |- _] => inversion_clear H
  | [H : Forall _ nil |- _] => inversion_clear H
  | [H : normal_derivation _ _ (quant _) |- _ ] =>
    let n := fresh "n" in move /inv_normal_quant : H => [n [? H]]
  | [H : normal_derivation _ _ (arr _ _) |- _ ] =>
    let n := fresh "n" in move /inv_normal_arr : H => [n [? H]]
  | [H : normal_derivation _ _ _ |- _] => move : H; inversion
  end).

Ltac decompose_chain :=
  do ? (
  match goal with
  | [H : chain ?s _ _ |- _] =>
    match eval hnf in s with
    | arr _ _ => (move /chain_arr : H => [? [? H]]); subst
    | atom _ => (move /chain_atom : H => [? ?]); try done; subst
    end
  end).

Ltac decompose_derivation :=
  do ? (
  match goal with
  | [H : derivation _ ?s |- _] =>
    match eval hnf in s with
    | arr _ _ => move /inv_arr : H => H
    | atom _ =>
      let s := fresh in
      let H' := fresh in
      move /inv_atom : H => [s [? [H' [? ?]]]]
    end
  end).

Ltac decompose_contains :=
  match goal with
  | [H : contains _ _ |- _] => inversion_clear H
  end.

Ltac decompose_lc :=
  do ? (
  match goal with
  | [H : lc _ ?s |- _] =>
    match eval hnf in s with
    | arr _ _ => inversion_clear H
    | var _ => inversion_clear H
    | atom _ => inversion_clear H
    end
  end).

Tactic Notation "gimme" "where" constr(p) :=
  lazymatch goal with
  | [H : context[p] |- _] => move : H
  end.

Lemma substitute_normal_derivation : forall (n : nat) (s : formula) (Γ : list formula) (a b : label),
  normal_derivation n Γ s -> normal_derivation n (map (substitute_label a b) Γ) (substitute_label a b s).
Proof.
elim /lt_wf_ind.

intros * => IH; intros.

gimme normal_derivation; inversion; cbn.
(*arr*)
apply : derive_arr.
rewrite <- map_cons.
apply : IH; try done + omega.
(*quant*)
match goal with [_ : context G [instantiate _ _ ?s'] |- _] => rename s' into s end.
apply : derive_quant => c.
case : (Label.eq_dec c a).

intro; subst c.
have [d Hd] := exists_fresh ([atom a; atom b; s] ++ (map (substitute_label a b) Γ)).
decompose_Forall.

do 2 (gimme shape (fresh_in d (atom _)); inversion).
rewrite -> (@instantiate_renaming_eq _ _ _ d); auto.
rewrite -> (@map_substitute_fresh_label d a (map (substitute_label a b) Γ)); auto.

intros.
rewrite -> instantiate_renaming_neq; auto.

(*atom*)
set Γ' := map (substitute_label a b) Γ.
match goal with [_ : In ?s' Γ |- _] => rename s' into s end.
set s' := (substitute_label a b) s.
rewrite if_fun.
match goal with [_ : chain s ?a' params |- _] => rename a' into c end.
set a' := (if Label.eqb a c then b else c).
set params' := map (substitute_label a b) params.
have ? : In s' Γ' by apply : in_map; assumption.
have ? : chain s' a' params' by apply : substitute_chain; assumption.

have ? : Forall (normal_derivation n0 Γ') params'.
gimme Forall; move : IH; clear; revert dependent params.
elim; cbn; first done.

intros; decompose_Forall.
eauto.

apply : derive_atom; try eassumption.
Qed.

Lemma substitute_derivation_bindable : forall (s : formula) (Γ : list formula) (a b : label),
  Forall (fresh_in a) Γ -> derivation Γ s -> derivation Γ (substitute_label a b s).
Proof.
intros.
have : Γ = map (substitute_label a b) Γ by apply map_substitute_fresh_label.
move => ->.
gimme derivation; move /normal_derivation_completeness => [? ?].
eauto using normal_derivation_soundness, substitute_normal_derivation.
Qed.

(*the usual presentation of intro_quant*)
Theorem intro_quant_fresh : ∀ (s: formula) (Γ : list formula) (a : label),
  Forall (fresh_in a) Γ -> fresh_in a s ->
  (derivation Γ (instantiate (atom a) 0 s)) → derivation Γ (Formula.quant s).
Proof.
move => s Γ a H *.
apply intro_quant => b.
gimme derivation.
move /(substitute_derivation_bindable b H).
rewrite -> rename_instantiation; auto.
Qed.

Lemma normal_weakening : ∀ (n : nat) (Γ Δ: list formula),
  (∀ (s : formula), In s Γ → In s Δ) → forall (t: formula), normal_derivation n Γ t → normal_derivation n Δ t.
Proof.
elim.
intros * => ? ?; inversion.

move => n IH Γ Δ H_in t; inversion.
(*case arr*)
constructor. apply: IH; try eassumption.
move => s'. move : (H_in s').
list_inclusion.

(*case quant*)
constructor. eauto.
(*case atom*)
apply: derive_atom; eauto.
apply : Forall_impl; last eassumption.
eauto.
Qed.

Lemma weakening : ∀ (Γ Δ: list formula) (t: formula),
  derivation Γ t → (∀ (s : formula), In s Γ → In s Δ) → derivation Δ t.
Proof.
intros *.
move /normal_derivation_completeness; case.
eauto using normal_derivation_soundness, normal_weakening.
Qed.

Lemma weakening_cons : ∀ (Γ: list formula) (s t: formula), derivation Γ t → derivation (s :: Γ) t.
Proof.
firstorder using weakening.
Qed.

Lemma context_generalization : forall (Γ Δ: list formula) (t : formula),
  derivation Γ t -> (forall (s : formula), In s Γ -> derivation Δ s) -> derivation Δ t.
Proof.
elim.
(*base case*)
intros.
apply: (weakening (Γ := [])) => //.
(*inductive case*)
intros * => IH.
intros until 1 => H'.
have ? : derivation l (arr a t) by derivation_rule.
have ? : derivation Δ (arr a t) => //.
apply IH => //; intros; apply H'; list_inclusion.
have ? : derivation Δ a by apply H'; list_inclusion.
derivation_rule.
Qed.

Lemma context_generalization_app : forall (Γ Δ Γ': list formula) (t : formula),
  derivation (Γ ++ Δ) t -> (forall (u : formula), In u Γ -> derivation Γ' u) -> derivation (Γ' ++ Δ) t.
Proof.
intros.
apply: (context_generalization). eassumption.
move => s H_In.
apply in_app_or in H_In.
case : H_In => H_In.
apply : (weakening (Γ := Γ')); auto with *.
derivation_rule.
Qed.

(*looks for In/chain statements and eliminates impossible cases*)
Ltac filter_context_chain :=
  let filter_context_chain_inner H_In :=
    move => H_In; subst => //;
    (do ? (
      match goal with
      | [|- chain ?s _ _ -> _] =>
        match eval hnf in s with
        | (arr _ _) => (let H' := fresh in move /chain_arr => [? [? H']]; move: H'; subst => //)
        | (atom _) => (move /chain_atom => [? ?]; subst => //)
        end
      end))
  in
    match goal with | [ H_In : In ?s _, H_c : chain ?s _ _ |- _] => move: H_In H_c;
    rewrite ? (in_app_iff, in_cons_iff, or_assoc);
    let t := (filter_context_chain_inner H_In) in decompose_or t end.

(*looks for In statements to derive current goal and eliminates trivial cases*)
Ltac filter_context_derivation :=
  let rec filter_context_derivation_inner H_In :=
    move => H_In; subst; try derivation_rule
  in
  match goal with | [ H_In : In ?s _ |- derivation _ ?s] =>
    move: H_In;
    rewrite ? (in_app_iff, in_cons_iff, or_assoc);
    let t := filter_context_derivation_inner H_In in decompose_or t
  end.