From Hammer Require Import Hammer.

Set Implicit Arguments.

Require Import Bool.
Require Import ZArith.
Require Import Znumtheory.
Require Import Zpow_facts.
Require Import DoubleType.
Require Import CyclicAxioms.

Local Open Scope Z_scope.

Section ZModulo.

Variable digits : positive.
Hypothesis digits_ne_1 : digits <> 1%positive.

Definition wB := base digits.

Definition t := Z.
Definition zdigits := Zpos digits.
Definition to_Z x := x mod wB.

Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99).

Notation "[+| c |]" :=
(interp_carry 1 wB to_Z c)  (at level 0, c at level 99).

Notation "[-| c |]" :=
(interp_carry (-1) wB to_Z c)  (at level 0, c at level 99).

Notation "[|| x ||]" :=
(zn2z_to_Z wB to_Z x)  (at level 0, x at level 99).

Lemma spec_more_than_1_digit: 1 < Zpos digits.
Proof. hammer_hook "ZModulo" "ZModulo.spec_more_than_1_digit".
generalize digits_ne_1; destruct digits; red; auto.
destruct 1; auto.
Qed.
Let digits_gt_1 := spec_more_than_1_digit.

Lemma wB_pos : wB > 0.
Proof. hammer_hook "ZModulo" "ZModulo.wB_pos".
apply Z.lt_gt.
unfold wB, base; auto with zarith.
Qed.
Hint Resolve wB_pos.

Lemma spec_to_Z_1 : forall x, 0 <= [|x|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_to_Z_1".
unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
Qed.

Lemma spec_to_Z_2 : forall x, [|x|] < wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_to_Z_2".
unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
Qed.
Hint Resolve spec_to_Z_1 spec_to_Z_2.

Lemma spec_to_Z : forall x, 0 <= [|x|] < wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_to_Z".
auto.
Qed.

Definition of_pos x :=
let (q,r) := Z.pos_div_eucl x wB in (N_of_Z q, r).

Lemma spec_of_pos : forall p,
Zpos p = (Z.of_N (fst (of_pos p)))*wB + [|(snd (of_pos p))|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_of_pos".
intros; unfold of_pos; simpl.
generalize (Z_div_mod_POS wB wB_pos p).
destruct (Z.pos_div_eucl p wB); simpl; destruct 1.
unfold to_Z; rewrite Zmod_small; auto.
assert (0 <= z).
replace z with (Zpos p / wB) by
(symmetry; apply Zdiv_unique with z0; auto).
apply Z_div_pos; auto with zarith.
replace (Z.of_N (N_of_Z z)) with z by
(destruct z; simpl; auto; elim H1; auto).
rewrite Z.mul_comm; auto.
Qed.

Lemma spec_zdigits : [|zdigits|] = Zpos digits.
Proof. hammer_hook "ZModulo" "ZModulo.spec_zdigits".
unfold to_Z, zdigits.
apply Zmod_small.
unfold wB, base.
split; auto with zarith.
apply Zpower2_lt_lin; auto with zarith.
Qed.

Definition zero := 0.
Definition one := 1.
Definition minus_one := wB - 1.

Lemma spec_0 : [|zero|] = 0.
Proof. hammer_hook "ZModulo" "ZModulo.spec_0".
unfold to_Z, zero.
apply Zmod_small; generalize wB_pos; auto with zarith.
Qed.

Lemma spec_1 : [|one|] = 1.
Proof. hammer_hook "ZModulo" "ZModulo.spec_1".
unfold to_Z, one.
apply Zmod_small; split; auto with zarith.
unfold wB, base.
apply Z.lt_trans with (Zpos digits); auto.
apply Zpower2_lt_lin; auto with zarith.
Qed.

Lemma spec_Bm1 : [|minus_one|] = wB - 1.
Proof. hammer_hook "ZModulo" "ZModulo.spec_Bm1".
unfold to_Z, minus_one.
apply Zmod_small; split; auto with zarith.
unfold wB, base.
cut (1 <= 2 ^ Zpos digits); auto with zarith.
apply Z.le_trans with (Zpos digits); auto with zarith.
apply Zpower2_le_lin; auto with zarith.
Qed.

Definition compare x y := Z.compare [|x|] [|y|].

Lemma spec_compare : forall x y,
compare x y = Z.compare [|x|] [|y|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_compare".   reflexivity. Qed.

Definition eq0 x :=
match [|x|] with Z0 => true | _ => false end.

Lemma spec_eq0 : forall x, eq0 x = true -> [|x|] = 0.
Proof. hammer_hook "ZModulo" "ZModulo.spec_eq0".
unfold eq0; intros; now destruct [|x|].
Qed.

Definition opp_c x :=
if eq0 x then C0 0 else C1 (- x).
Definition opp x := - x.
Definition opp_carry x := - x - 1.

Lemma spec_opp_c : forall x, [-|opp_c x|] = -[|x|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_opp_c".
intros; unfold opp_c, to_Z; auto.
case_eq (eq0 x); intros; unfold interp_carry.
fold [|x|]; rewrite (spec_eq0 x H); auto.
assert (x mod wB <> 0).
unfold eq0, to_Z in H.
intro H0; rewrite H0 in H; discriminate.
rewrite Z_mod_nz_opp_full; auto with zarith.
Qed.

Lemma spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_opp".
intros; unfold opp, to_Z; auto.
change ((- x) mod wB = (0 - (x mod wB)) mod wB).
rewrite Zminus_mod_idemp_r; simpl; auto.
Qed.

Lemma spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1.
Proof. hammer_hook "ZModulo" "ZModulo.spec_opp_carry".
intros; unfold opp_carry, to_Z; auto.
replace (- x - 1) with (- 1 - x) by omega.
rewrite <- Zminus_mod_idemp_r.
replace ( -1 - x mod wB) with (0 + ( -1 - x mod wB)) by omega.
rewrite <- (Z_mod_same_full wB).
rewrite Zplus_mod_idemp_l.
replace (wB + (-1 - x mod wB)) with (wB - x mod wB -1) by omega.
apply Zmod_small.
generalize (Z_mod_lt x wB wB_pos); omega.
Qed.

Definition succ_c x :=
let y := Z.succ x in
if eq0 y then C1 0 else C0 y.

Definition add_c x y :=
let z := [|x|] + [|y|] in
if Z_lt_le_dec z wB then C0 z else C1 (z-wB).

Definition add_carry_c x y :=
let z := [|x|]+[|y|]+1 in
if Z_lt_le_dec z wB then C0 z else C1 (z-wB).

Definition succ := Z.succ.
Definition add := Z.add.
Definition add_carry x y := x + y + 1.

Lemma Zmod_equal :
forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z.
Proof. hammer_hook "ZModulo" "ZModulo.Zmod_equal".
intros.
generalize (Z_div_mod_eq (x-y) z H); rewrite H0, Z.add_0_r.
remember ((x-y)/z) as k.
rewrite Z.sub_move_r, Z.add_comm, Z.mul_comm. intros ->.
now apply Z_mod_plus.
Qed.

Lemma spec_succ_c : forall x, [+|succ_c x|] = [|x|] + 1.
Proof. hammer_hook "ZModulo" "ZModulo.spec_succ_c".
intros; unfold succ_c, to_Z, Z.succ.
case_eq (eq0 (x+1)); intros; unfold interp_carry.

rewrite Z.mul_1_l.
replace (wB + 0 mod wB) with wB by auto with zarith.
symmetry. rewrite Z.add_move_r.
assert ((x+1) mod wB = 0) by (apply spec_eq0; auto).
replace (wB-1) with ((wB-1) mod wB) by
(apply Zmod_small; generalize wB_pos; omega).
rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto.
apply Zmod_equal; auto.

assert ((x+1) mod wB <> 0).
unfold eq0, to_Z in *; now destruct ((x+1) mod wB).
assert (x mod wB + 1 <> wB).
contradict H0.
rewrite Z.add_move_r in H0; simpl in H0.
rewrite <- Zplus_mod_idemp_l; rewrite H0.
replace (wB-1+1) with wB; auto with zarith; apply Z_mod_same; auto.
rewrite <- Zplus_mod_idemp_l.
apply Zmod_small.
generalize (Z_mod_lt x wB wB_pos); omega.
Qed.

Lemma spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_add_c".
intros; unfold add_c, to_Z, interp_carry.
destruct Z_lt_le_dec.
apply Zmod_small;
generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r.
apply Zmod_small;
generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
Qed.

Lemma spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1.
Proof. hammer_hook "ZModulo" "ZModulo.spec_add_carry_c".
intros; unfold add_carry_c, to_Z, interp_carry.
destruct Z_lt_le_dec.
apply Zmod_small;
generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r.
apply Zmod_small;
generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
Qed.

Lemma spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_succ".
intros; unfold succ, to_Z, Z.succ.
symmetry; apply Zplus_mod_idemp_l.
Qed.

Lemma spec_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_add".
intros; unfold add, to_Z; apply Zplus_mod.
Qed.

Lemma spec_add_carry :
forall x y, [|add_carry x y|] = ([|x|] + [|y|] + 1) mod wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_add_carry".
intros; unfold add_carry, to_Z.
rewrite <- Zplus_mod_idemp_l.
rewrite (Zplus_mod x y).
rewrite Zplus_mod_idemp_l; auto.
Qed.

Definition pred_c x :=
if eq0 x then C1 (wB-1) else C0 (x-1).

Definition sub_c x y :=
let z := [|x|]-[|y|] in
if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z.

Definition sub_carry_c x y :=
let z := [|x|]-[|y|]-1 in
if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z.

Definition pred := Z.pred.
Definition sub := Z.sub.
Definition sub_carry x y := x - y - 1.

Lemma spec_pred_c : forall x, [-|pred_c x|] = [|x|] - 1.
Proof. hammer_hook "ZModulo" "ZModulo.spec_pred_c".
intros; unfold pred_c, to_Z, interp_carry.
case_eq (eq0 x); intros.
fold [|x|]; rewrite spec_eq0; auto.
replace ((wB-1) mod wB) with (wB-1); auto with zarith.
symmetry; apply Zmod_small; generalize wB_pos; omega.

assert (x mod wB <> 0).
unfold eq0, to_Z in *; now destruct (x mod wB).
rewrite <- Zminus_mod_idemp_l.
apply Zmod_small.
generalize (Z_mod_lt x wB wB_pos); omega.
Qed.

Lemma spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_sub_c".
intros; unfold sub_c, to_Z, interp_carry.
destruct Z_lt_le_dec.
replace ((wB + (x mod wB - y mod wB)) mod wB) with
(wB + (x mod wB - y mod wB)).
omega.
symmetry; apply Zmod_small.
generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.

apply Zmod_small.
generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
Qed.

Lemma spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1.
Proof. hammer_hook "ZModulo" "ZModulo.spec_sub_carry_c".
intros; unfold sub_carry_c, to_Z, interp_carry.
destruct Z_lt_le_dec.
replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with
(wB + (x mod wB - y mod wB -1)).
omega.
symmetry; apply Zmod_small.
generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.

apply Zmod_small.
generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
Qed.

Lemma spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_pred".
intros; unfold pred, to_Z, Z.pred.
rewrite <- Zplus_mod_idemp_l; auto.
Qed.

Lemma spec_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_sub".
intros; unfold sub, to_Z; apply Zminus_mod.
Qed.

Lemma spec_sub_carry :
forall x y, [|sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_sub_carry".
intros; unfold sub_carry, to_Z.
rewrite <- Zminus_mod_idemp_l.
rewrite (Zminus_mod x y).
rewrite Zminus_mod_idemp_l.
auto.
Qed.

Definition mul_c x y :=
let (h,l) := Z.div_eucl ([|x|]*[|y|]) wB in
if eq0 h then if eq0 l then W0 else WW h l else WW h l.

Definition mul := Z.mul.

Definition square_c x := mul_c x x.

Lemma spec_mul_c : forall x y, [|| mul_c x y ||] = [|x|] * [|y|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_mul_c".
intros; unfold mul_c, zn2z_to_Z.
assert (Z.div_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)).
unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Z.div_eucl as (h,l).
destruct 1; injection H as ? ?.
rewrite H0.
assert ([|l|] = l).
apply Zmod_small; auto.
assert ([|h|] = h).
apply Zmod_small.
subst h.
split.
apply Z_div_pos; auto with zarith.
apply Zdiv_lt_upper_bound; auto with zarith.
apply Z.mul_lt_mono_nonneg; auto with zarith.
clear H H0 H1 H2.
case_eq (eq0 h); simpl; intros.
case_eq (eq0 l); simpl; intros.
rewrite <- H3, <- H4, (spec_eq0 h), (spec_eq0 l); auto with zarith.
rewrite H3, H4; auto with zarith.
rewrite H3, H4; auto with zarith.
Qed.

Lemma spec_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_mul".
intros; unfold mul, to_Z; apply Zmult_mod.
Qed.

Lemma spec_square_c : forall x, [|| square_c x||] = [|x|] * [|x|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_square_c".
intros x; exact (spec_mul_c x x).
Qed.

Definition div x y := Z.div_eucl [|x|] [|y|].

Lemma spec_div : forall a b, 0 < [|b|] ->
let (q,r) := div a b in
[|a|] = [|q|] * [|b|] + [|r|] /\
0 <= [|r|] < [|b|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_div".
intros; unfold div.
assert ([|b|]>0) by auto with zarith.
assert (Z.div_eucl [|a|] [|b|] = ([|a|]/[|b|], [|a|] mod [|b|])).
unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
generalize (Z_div_mod [|a|] [|b|] H0).
destruct Z.div_eucl as (q,r); destruct 1; intros.
injection H1 as ? ?.
assert ([|r|]=r).
apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
auto with zarith.
assert ([|q|]=q).
apply Zmod_small.
subst q.
split.
apply Z_div_pos; auto with zarith.
apply Zdiv_lt_upper_bound; auto with zarith.
apply Z.lt_le_trans with (wB*1).
rewrite Z.mul_1_r; auto with zarith.
apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith.
rewrite H5, H6; rewrite Z.mul_comm; auto with zarith.
Qed.

Definition div_gt := div.

Lemma spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
let (q,r) := div_gt a b in
[|a|] = [|q|] * [|b|] + [|r|] /\
0 <= [|r|] < [|b|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_div_gt".
intros.
apply spec_div; auto.
Qed.

Definition modulo x y := [|x|] mod [|y|].
Definition modulo_gt x y := [|x|] mod [|y|].

Lemma spec_modulo :  forall a b, 0 < [|b|] ->
[|modulo a b|] = [|a|] mod [|b|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_modulo".
intros; unfold modulo.
apply Zmod_small.
assert ([|b|]>0) by auto with zarith.
generalize (Z_mod_lt [|a|] [|b|] H0) (Z_mod_lt b wB wB_pos).
fold [|b|]; omega.
Qed.

Lemma spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
[|modulo_gt a b|] = [|a|] mod [|b|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_modulo_gt".
intros; apply spec_modulo; auto.
Qed.

Definition gcd x y := Z.gcd [|x|] [|y|].
Definition gcd_gt x y := Z.gcd [|x|] [|y|].

Lemma Zgcd_bound : forall a b, 0<=a -> 0<=b -> Z.gcd a b <= Z.max a b.
Proof. hammer_hook "ZModulo" "ZModulo.Zgcd_bound".
intros.
generalize (Zgcd_is_gcd a b); inversion_clear 1.
destruct H2 as (q,H2); destruct H3 as (q',H3); clear H4.
assert (H4:=Z.gcd_nonneg a b).
destruct (Z.eq_dec (Z.gcd a b) 0) as [->|Hneq].
generalize (Zmax_spec a b); omega.
assert (0 <= q).
apply Z.mul_le_mono_pos_r with (Z.gcd a b); auto with zarith.
destruct (Z.eq_dec q 0).

subst q; simpl in *; subst a; simpl; auto.
generalize (Zmax_spec 0 b) (Zabs_spec b); omega.

apply Z.le_trans with a.
rewrite H2 at 2.
rewrite <- (Z.mul_1_l (Z.gcd a b)) at 1.
apply Z.mul_le_mono_nonneg; auto with zarith.
generalize (Zmax_spec a b); omega.
Qed.

Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_gcd".
intros; unfold gcd.
generalize (Z_mod_lt a wB wB_pos)(Z_mod_lt b wB wB_pos); intros.
fold [|a|] in *; fold [|b|] in *.
replace ([|Z.gcd [|a|] [|b|]|]) with (Z.gcd [|a|] [|b|]).
apply Zgcd_is_gcd.
symmetry; apply Zmod_small.
split.
apply Z.gcd_nonneg.
apply Z.le_lt_trans with (Z.max [|a|] [|b|]).
apply Zgcd_bound; auto with zarith.
generalize (Zmax_spec [|a|] [|b|]); omega.
Qed.

Lemma spec_gcd_gt : forall a b, [|a|] > [|b|] ->
Zis_gcd [|a|] [|b|] [|gcd_gt a b|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_gcd_gt".
intros. apply spec_gcd; auto.
Qed.

Definition div21 a1 a2 b :=
Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|].

Lemma spec_div21 : forall a1 a2 b,
wB/2 <= [|b|] ->
[|a1|] < [|b|] ->
let (q,r) := div21 a1 a2 b in
[|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
0 <= [|r|] < [|b|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_div21".
intros; unfold div21.
generalize (Z_mod_lt a1 wB wB_pos); fold [|a1|]; intros.
generalize (Z_mod_lt a2 wB wB_pos); fold [|a2|]; intros.
assert ([|b|]>0) by auto with zarith.
remember ([|a1|]*wB+[|a2|]) as a.
assert (Z.div_eucl a [|b|] = (a/[|b|], a mod [|b|])).
unfold Z.modulo, Z.div; destruct Z.div_eucl; auto.
generalize (Z_div_mod a [|b|] H3).
destruct Z.div_eucl as (q,r); destruct 1; intros.
injection H4 as ? ?.
assert ([|r|]=r).
apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
auto with zarith.
assert ([|q|]=q).
apply Zmod_small.
subst q.
split.
apply Z_div_pos; auto with zarith.
subst a; auto with zarith.
apply Zdiv_lt_upper_bound; auto with zarith.
subst a.
replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring.
apply Z.lt_le_trans with ([|a1|]*wB+wB); auto with zarith.
rewrite H8, H9; rewrite Z.mul_comm; auto with zarith.
Qed.

Definition add_mul_div p x y :=
([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos digits) - [|p|]))).
Lemma spec_add_mul_div : forall x y p,
[|p|] <= Zpos digits ->
[| add_mul_div p x y |] =
([|x|] * (2 ^ [|p|]) +
[|y|] / (2 ^ ((Zpos digits) - [|p|]))) mod wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_add_mul_div".
intros; unfold add_mul_div; auto.
Qed.

Definition pos_mod p w := [|w|] mod (2 ^ [|p|]).
Lemma spec_pos_mod : forall w p,
[|pos_mod p w|] = [|w|] mod (2 ^ [|p|]).
Proof. hammer_hook "ZModulo" "ZModulo.spec_pos_mod".
intros; unfold pos_mod.
apply Zmod_small.
generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros.
split.
destruct H; auto using Z.lt_gt with zarith.
apply Z.le_lt_trans with [|w|]; auto with zarith.
apply Zmod_le; auto with zarith.
Qed.

Definition is_even x :=
if Z.eq_dec ([|x|] mod 2) 0 then true else false.

Lemma spec_is_even : forall x,
if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1.
Proof. hammer_hook "ZModulo" "ZModulo.spec_is_even".
intros; unfold is_even; destruct Z.eq_dec; auto.
generalize (Z_mod_lt [|x|] 2); omega.
Qed.

Definition sqrt x := Z.sqrt [|x|].
Lemma spec_sqrt : forall x,
[|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2.
Proof. hammer_hook "ZModulo" "ZModulo.spec_sqrt".
intros.
unfold sqrt.
repeat rewrite Z.pow_2_r.
replace [|Z.sqrt [|x|]|] with (Z.sqrt [|x|]).
apply Z.sqrt_spec; auto with zarith.
symmetry; apply Zmod_small.
split. apply Z.sqrt_nonneg; auto.
apply Z.le_lt_trans with [|x|]; auto.
apply Z.sqrt_le_lin; auto.
Qed.

Definition sqrt2 x y :=
let z := [|x|]*wB+[|y|] in
match z with
| Z0 => (0, C0 0)
| Zpos p =>
let (s,r) := Z.sqrtrem (Zpos p) in
(s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB))
| Zneg _ => (0, C0 0)
end.

Lemma spec_sqrt2 : forall x y,
wB/ 4 <= [|x|] ->
let (s,r) := sqrt2 x y in
[||WW x y||] = [|s|] ^ 2 + [+|r|] /\
[+|r|] <= 2 * [|s|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_sqrt2".
intros; unfold sqrt2.
simpl zn2z_to_Z.
remember ([|x|]*wB+[|y|]) as z.
destruct z.
auto with zarith.
generalize (Z.sqrtrem_spec (Zpos p)).
destruct Z.sqrtrem as (s,r); intros [U V]; auto with zarith.
assert (s < wB).
destruct (Z_lt_le_dec s wB); auto.
assert (wB * wB <= Zpos p).
rewrite U.
apply Z.le_trans with (s*s); try omega.
apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith.
assert (Zpos p < wB*wB).
rewrite Heqz.
replace (wB*wB) with ((wB-1)*wB+wB) by ring.
apply Z.add_le_lt_mono; auto with zarith.
apply Z.mul_le_mono_nonneg; auto with zarith.
generalize (spec_to_Z x); auto with zarith.
generalize wB_pos; auto with zarith.
omega.
replace [|s|] with s by (symmetry; apply Zmod_small; auto with zarith).
destruct Z_lt_le_dec; unfold interp_carry.
replace [|r|] with r by (symmetry; apply Zmod_small; auto with zarith).
rewrite Z.pow_2_r; auto with zarith.
replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith).
rewrite Z.pow_2_r; omega.

assert (0<=Zneg p).
rewrite Heqz; generalize wB_pos; auto with zarith.
compute in H0; elim H0; auto.
Qed.

Lemma two_p_power2 : forall x, x>=0 -> two_p x = 2 ^ x.
Proof. hammer_hook "ZModulo" "ZModulo.two_p_power2".
intros.
unfold two_p.
destruct x; simpl; auto.
apply two_power_pos_correct.
Qed.

Definition head0 x := match [|x|] with
| Z0 => zdigits
| Zpos p => zdigits - log_inf p - 1
| _ => 0
end.

Lemma spec_head00:  forall x, [|x|] = 0 -> [|head0 x|] = Zpos digits.
Proof. hammer_hook "ZModulo" "ZModulo.spec_head00".
unfold head0; intros.
rewrite H; simpl.
apply spec_zdigits.
Qed.

Lemma log_inf_bounded : forall x p, Zpos x < 2^p -> log_inf x < p.
Proof. hammer_hook "ZModulo" "ZModulo.log_inf_bounded".
induction x; simpl; intros.

assert (0 < p) by (destruct p; compute; auto with zarith; discriminate).
cut (log_inf x < p - 1); [omega| ].
apply IHx.
change (Zpos x~1) with (2*(Zpos x)+1) in H.
replace p with (Z.succ (p-1)) in H; auto with zarith.
rewrite Z.pow_succ_r in H; auto with zarith.

assert (0 < p) by (destruct p; compute; auto with zarith; discriminate).
cut (log_inf x < p - 1); [omega| ].
apply IHx.
change (Zpos x~0) with (2*(Zpos x)) in H.
replace p with (Z.succ (p-1)) in H; auto with zarith.
rewrite Z.pow_succ_r in H; auto with zarith.

simpl; intros; destruct p; compute; auto with zarith.
Qed.

Lemma spec_head0  : forall x,  0 < [|x|] ->
wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB.
Proof. hammer_hook "ZModulo" "ZModulo.spec_head0".
intros; unfold head0.
generalize (spec_to_Z x).
destruct [|x|]; try discriminate.
intros.
destruct (log_inf_correct p).
rewrite 2 two_p_power2 in H2; auto with zarith.
assert (0 <= zdigits - log_inf p - 1 < wB).
split.
cut (log_inf p < zdigits); try omega.
unfold zdigits.
unfold wB, base in *.
apply log_inf_bounded; auto with zarith.
apply Z.lt_trans with zdigits.
omega.
unfold zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith.

unfold to_Z; rewrite (Zmod_small _ _ H3).
destruct H2.
split.
apply Z.le_trans with (2^(zdigits - log_inf p - 1)*(2^log_inf p)).
apply Zdiv_le_upper_bound; auto with zarith.
rewrite <- Zpower_exp; auto with zarith.
rewrite Z.mul_comm; rewrite <- Z.pow_succ_r; auto with zarith.
replace (Z.succ (zdigits - log_inf p -1 +log_inf p)) with zdigits
by ring.
unfold wB, base, zdigits; auto with zarith.
apply Z.mul_le_mono_nonneg; auto with zarith.

apply Z.lt_le_trans
with (2^(zdigits - log_inf p - 1)*(2^(Z.succ (log_inf p)))).
apply Z.mul_lt_mono_pos_l; auto with zarith.
rewrite <- Zpower_exp; auto with zarith.
replace (zdigits - log_inf p -1 +Z.succ (log_inf p)) with zdigits
by ring.
unfold wB, base, zdigits; auto with zarith.
Qed.

Fixpoint Ptail p := match p with
| xO p => (Ptail p)+1
| _ => 0
end.

Lemma Ptail_pos : forall p, 0 <= Ptail p.
Proof. hammer_hook "ZModulo" "ZModulo.Ptail_pos".
induction p; simpl; auto with zarith.
Qed.
Hint Resolve Ptail_pos.

Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d.
Proof. hammer_hook "ZModulo" "ZModulo.Ptail_bounded".
induction p; try (compute; auto; fail).
intros; simpl.
assert (d <> xH).
intro; subst.
compute in H; destruct p; discriminate.
assert (Z.succ (Zpos (Pos.pred d)) = Zpos d).
simpl; f_equal.
rewrite Pos.add_1_r.
destruct (Pos.succ_pred_or d); auto.
rewrite H1 in H0; elim H0; auto.
assert (Ptail p < Zpos (Pos.pred d)).
apply IHp.
apply Z.mul_lt_mono_pos_r with 2; auto with zarith.
rewrite (Z.mul_comm (Zpos p)).
change (2 * Zpos p) with (Zpos p~0).
rewrite Z.mul_comm.
rewrite <- Z.pow_succ_r; auto with zarith.
rewrite H1; auto.
rewrite <- H1; omega.
Qed.

Definition tail0 x :=
match [|x|] with
| Z0 => zdigits
| Zpos p => Ptail p
| Zneg _ => 0
end.

Lemma spec_tail00:  forall x, [|x|] = 0 -> [|tail0 x|] = Zpos digits.
Proof. hammer_hook "ZModulo" "ZModulo.spec_tail00".
unfold tail0; intros.
rewrite H; simpl.
apply spec_zdigits.
Qed.

Lemma spec_tail0  : forall x, 0 < [|x|] ->
exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]).
Proof. hammer_hook "ZModulo" "ZModulo.spec_tail0".
intros; unfold tail0.
generalize (spec_to_Z x).
destruct [|x|]; try discriminate; intros.
assert ([|Ptail p|] = Ptail p).
apply Zmod_small.
split; auto.
unfold wB, base in *.
apply Z.lt_trans with (Zpos digits).
apply Ptail_bounded; auto with zarith.
apply Zpower2_lt_lin; auto with zarith.
rewrite H1.

clear; induction p.
exists (Zpos p); simpl; rewrite Pos.mul_1_r; auto with zarith.
destruct IHp as (y & Yp & Ye).
exists y.
split; auto.
change (Zpos p~0) with (2*Zpos p).
rewrite Ye.
change (Ptail p~0) with (Z.succ (Ptail p)).
rewrite Z.pow_succ_r; auto; ring.

exists 0; simpl; auto with zarith.
Qed.

Definition lor := Z.lor.
Definition land := Z.land.
Definition lxor := Z.lxor.

Lemma spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_lor".
unfold lor, to_Z.
apply Z.bits_inj'; intros n Hn. rewrite Z.lor_spec.
unfold wB, base.
destruct (Z.le_gt_cases (Z.pos digits) n).
- rewrite !Z.mod_pow2_bits_high; auto with zarith.
- rewrite !Z.mod_pow2_bits_low, Z.lor_spec; auto with zarith.
Qed.

Lemma spec_land x y : [|land x y|] = Z.land [|x|] [|y|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_land".
unfold land, to_Z.
apply Z.bits_inj'; intros n Hn. rewrite Z.land_spec.
unfold wB, base.
destruct (Z.le_gt_cases (Z.pos digits) n).
- rewrite !Z.mod_pow2_bits_high; auto with zarith.
- rewrite !Z.mod_pow2_bits_low, Z.land_spec; auto with zarith.
Qed.

Lemma spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|].
Proof. hammer_hook "ZModulo" "ZModulo.spec_lxor".
unfold lxor, to_Z.
apply Z.bits_inj'; intros n Hn. rewrite Z.lxor_spec.
unfold wB, base.
destruct (Z.le_gt_cases (Z.pos digits) n).
- rewrite !Z.mod_pow2_bits_high; auto with zarith.
- rewrite !Z.mod_pow2_bits_low, Z.lxor_spec; auto with zarith.
Qed.

Instance zmod_ops : ZnZ.Ops Z := ZnZ.MkOps
(digits : positive)
(zdigits: t)
(to_Z   : t -> Z)
(of_pos : positive -> N * t)
(head0  : t -> t)
(tail0  : t -> t)

(zero   : t)
(one    : t)
(minus_one : t)

(compare     : t -> t -> comparison)
(eq0         : t -> bool)

(opp_c       : t -> carry t)
(opp         : t -> t)
(opp_carry   : t -> t)

(succ_c      : t -> carry t)
(add_c       : t -> t -> carry t)
(add_carry_c : t -> t -> carry t)
(succ        : t -> t)
(add         : t -> t -> t)
(add_carry   : t -> t -> t)

(pred_c      : t -> carry t)
(sub_c       : t -> t -> carry t)
(sub_carry_c : t -> t -> carry t)
(pred        : t -> t)
(sub         : t -> t -> t)
(sub_carry   : t -> t -> t)

(mul_c       : t -> t -> zn2z t)
(mul         : t -> t -> t)
(square_c    : t -> zn2z t)

(div21       : t -> t -> t -> t*t)
(div_gt      : t -> t -> t * t)
(div         : t -> t -> t * t)

(modulo_gt      : t -> t -> t)
(modulo         : t -> t -> t)

(gcd_gt      : t -> t -> t)
(gcd         : t -> t -> t)
(add_mul_div : t -> t -> t -> t)
(pos_mod     : t -> t -> t)

(is_even     : t -> bool)
(sqrt2       : t -> t -> t * carry t)
(sqrt        : t -> t)
(lor         : t -> t -> t)
(land         : t -> t -> t)
(lxor         : t -> t -> t).

Instance zmod_specs : ZnZ.Specs zmod_ops := ZnZ.MkSpecs
spec_to_Z
spec_of_pos
spec_zdigits
spec_more_than_1_digit

spec_0
spec_1
spec_Bm1

spec_compare
spec_eq0

spec_opp_c
spec_opp
spec_opp_carry

spec_succ_c
spec_add_c
spec_add_carry_c
spec_succ
spec_add
spec_add_carry

spec_pred_c
spec_sub_c
spec_sub_carry_c
spec_pred
spec_sub
spec_sub_carry

spec_mul_c
spec_mul
spec_square_c

spec_div21
spec_div_gt
spec_div

spec_modulo_gt
spec_modulo

spec_gcd_gt
spec_gcd

spec_head00
spec_head0
spec_tail00
spec_tail0

spec_add_mul_div
spec_pos_mod

spec_is_even
spec_sqrt2
spec_sqrt
spec_lor
spec_land
spec_lxor.

End ZModulo.

Module Type PositiveNotOne.
Parameter p : positive.
Axiom not_one : p <> 1%positive.
End PositiveNotOne.

Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType.
Definition t := Z.
Instance ops : ZnZ.Ops t := zmod_ops P.p.
Instance specs : ZnZ.Specs ops := zmod_specs P.not_one.
End ZModuloCyclicType.


Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Hints.PullPush.
Require Import Crypto.Util.ZUtil.ZSimplify.Core.
Require Import Crypto.Util.ZUtil.ZSimplify.Simple.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.ZeroBounds.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Local Open Scope Z_scope.

Module Z.
#[global]
  Hint Rewrite Z.log2_pow2 Z.pow_1_r using solve [auto using Z.log2_nonneg with zarith] : push_Zpow.

  Lemma cc_m_eq_full : forall s x, Z.cc_m s x = if (s =? 1) then x * 2 else x / (s / 2).
  Proof.
    intros; cbv [Z.cc_m].
    destruct (Decidable.dec (2 < s)).
    { assert (1 <= Z.log2 s) by (rewrite <-Z.log2_2; auto using Z.log2_le_mono with lia).
      break_match; Z.ltb_to_lt; try lia; [].
      match goal with H : _ = s |- _ => rewrite <-H end.
      autorewrite with Zshift_to_pow push_Zpow.
      reflexivity. }
    { assert (s < 0 \/ s = 0 \/ s = 1 \/ s = 2) by lia.
      destruct_head'_or; (subst s || destruct s); try reflexivity; try (cbn; autorewrite with zsimplify_const; lia).
      change (Z.log2 1 - 1) with (-1).
      rewrite (Z.shiftr_opp_r _ 1), Z.shiftl_mul_pow2 by lia.
      reflexivity. }
  Qed.

  Lemma cc_m_eq : forall s x, 2 < s -> Z.cc_m s x = x / (s / 2).
  Proof. intros; rewrite cc_m_eq_full; break_match; Z.ltb_to_lt; lia. Qed.

  Lemma cc_m_small : forall s x, s mod 2 = 0 -> 0 <= x < s -> 0 <= Z.cc_m s x < 2.
  Proof.
    intros. rewrite cc_m_eq_full.
    repeat match goal with
           | _ => break_innermost_match_step
           | _ => progress Z.ltb_to_lt
           | _ => split
           | _ => apply Z.div_lt_upper_bound
           | _ => solve [Z.zero_bounds]
           end.
    Z.div_mod_to_quot_rem_in_goal; lia.
  Qed.

  Lemma cc_m_Proper_le_r_gen s
    : (0 <= s /\ Proper (Z.le ==> Z.le) (Definitions.Z.cc_m s))
      \/ (s < 0 /\ Proper (Basics.flip Z.le ==> Z.le) (Definitions.Z.cc_m s)).
  Proof.
    cbv [Basics.flip].
    destruct (Z_lt_le_dec s 0); [ right | left ]; (split; [ assumption | ]).
    all: intros x0 x1 H; rewrite !cc_m_eq_full; break_innermost_match; Z.ltb_to_lt; [ nia | ].
    all: Z.div_mod_to_quot_rem; nia.
  Qed.
#[global]
  Hint Resolve cc_m_Proper_le_r_gen : zarith.

  Lemma cc_m_Proper_le_r s
    : Proper (Z.le ==> Z.le) (Definitions.Z.cc_m s)
      \/ Proper (Basics.flip Z.le ==> Z.le) (Definitions.Z.cc_m s).
  Proof. pose proof (cc_m_Proper_le_r_gen s); tauto. Qed.
#[global]
  Hint Resolve cc_m_Proper_le_r : zarith.

  Lemma cc_m_Proper_le_r_pos s
    : Proper (Z.le ==> Z.le) (Definitions.Z.cc_m (Z.pos s)).
  Proof. pose proof (cc_m_Proper_le_r_gen (Z.pos s)); intuition lia. Qed.
#[global]
  Hint Resolve cc_m_Proper_le_r_pos : zarith.

  Lemma cc_m_Proper_le_r_neg s
    : Proper (Basics.flip Z.le ==> Z.le) (Definitions.Z.cc_m (Z.neg s)).
  Proof. pose proof (cc_m_Proper_le_r_gen (Z.neg s)); intuition lia. Qed.
#[global]
  Hint Resolve cc_m_Proper_le_r_neg : zarith.

  Lemma cc_m_Proper_le_r_0
    : Proper (Z.le ==> Z.le) (Definitions.Z.cc_m 0).
  Proof. pose proof (cc_m_Proper_le_r_gen 0); intuition lia. Qed.
#[global]
  Hint Resolve cc_m_Proper_le_r_0 : zarith.
End Z.


From FA Require Import String DFA.
From mathcomp Require Import all_ssreflect.

Record nfa: Type :=
  mknfa
  {
     nfa_state     :> finType;
     nfa_start     : {set nfa_state};
     nfa_transition: nfa_state -> Sigma -> {set nfa_state};
     nfa_finals    : {set nfa_state}
  }.

Fixpoint nfa_multistep (n: nfa) (A: {set (@nfa_state n) }) (s: String): { set (@nfa_state n) } :=
  match s with
    | eps => A
    | glue x y => \bigcup_(q in (nfa_multistep n A x)) nfa_transition n q y
  end.

(* Definition nfa_acceptance (n: nfa) (A: {set (@nfa_state n) }) (x: String) :=
  nfa_multistep n A x :&: (@nfa_finals n) != set0. *)

Definition nfa_acceptance (n: nfa) (A: {set (@nfa_state n) }) (x: String) :=
[exists y, (y\in(nfa_multistep n A x)) && (y \in (@nfa_finals n))].

Definition nfa_language (n: nfa) := [pred s: String | (nfa_acceptance n (@nfa_start n) s)].

(* alternative multistep for NFAs -- computable? *)

Definition nfa_multistepH (n: nfa) (A: {set (@nfa_state n) }) (c: Sigma): { set (@nfa_state n) } :=
  let l := enum A in
  let fix recurse l c :=
    match l with
      | nil   => set0
      | x::xs => (@nfa_transition n x c) :|: recurse xs c
    end
  in recurse l c.

Fixpoint nfa_multistepA (n: nfa) (A: {set (@nfa_state n) }) (s: String): { set (@nfa_state n) } :=
  match s with
    | eps       => A
    | glue xs c => nfa_multistepH n (nfa_multistepA n A xs) c
  end.


(**************************************************
 * Author: Ana Nora Evans (ananevans@virginia.edu)
 **************************************************)
Require Import Coq.ZArith.ZArith.
Require Import Coq.Structures.Equalities.
Require Import Coq.Lists.List.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.

Require Import Common.Definitions.
Require Import Common.Util.
Require Import Common.Maps.
Require Import TargetSFI.SFIUtil.
Require Import TargetSFI.Machine.

Require Import TargetSFI.SFITestUtil.
From mathcomp.ssreflect Require Import ssreflect ssrbool eqtype.

Import BinNatMapExtra.
Import SFI.

Example test_CODE_DATA_BIT_MASK :
  SFI.CODE_DATA_BIT_MASK = hex2N "10000".
Proof. unfold CODE_DATA_BIT_MASK. unfold OFFSET_BITS_NO. unfold COMP_BITS_NO.
       simpl. unfold hex2N. reflexivity. Qed.

Example test_AND_DATA_MASK :
  SFI.AND_DATA_MASK = hex2N "FE0FFF".
Proof.
  compute. eauto. Qed.

  (* unfold AND_DATA_MASK. unfold OFFSET_BITS_NO. *)
  (* unfold COMP_BITS_NO. unfold BLOCK_BITS_NO. *)
  (* reflexivity. Qed. *)

Example test_AND_CODE_MASK :
  SFI.AND_CODE_MASK = hex2N "FE0FF0".
Proof.
  unfold AND_DATA_MASK. unfold OFFSET_BITS_NO.
  unfold COMP_BITS_NO. unfold BLOCK_BITS_NO.
  reflexivity. Qed.

Example test_address_of1 :
   address_of 1%N 0%N 0%N =  hex2N "001000".
Proof.
  unfold address_of.
  unfold OFFSET_BITS_NO. unfold COMP_BITS_NO.
  reflexivity. Qed.

Example test_C_SFI :
  C_SFI (hex2N "003000") = 3%N.
Proof.
  unfold C_SFI.
  unfold OFFSET_BITS_NO. unfold COMP_BITS_NO.
  reflexivity. Qed.

Example test_is_code_address_true :
  is_code_address (hex2N "00B000") = true.
Proof.
  unfold is_code_address.
  unfold CODE_DATA_BIT_MASK. unfold COMP_BITS_NO. unfold OFFSET_BITS_NO.
  reflexivity. Qed.

Example test_is_code_address_false :
  is_code_address (hex2N "01F000") = false.
Proof.
  unfold is_code_address.
  unfold CODE_DATA_BIT_MASK. unfold COMP_BITS_NO. unfold OFFSET_BITS_NO.
  reflexivity. Qed.

Example test_or_data_mask0 :
  or_data_mask 0%N = (hex2N "010000").
Proof.
  unfold or_data_mask.
  unfold COMP_BITS_NO. unfold OFFSET_BITS_NO.
  reflexivity. Qed.

Example test_or_data_mask3 :
  or_data_mask 3%N = (hex2N "013000").
Proof.
  unfold or_data_mask.
  unfold COMP_BITS_NO. unfold OFFSET_BITS_NO.
  reflexivity. Qed.

Example test_or_code_mask0 :
  or_code_mask 0%N = (hex2N "000000").
Proof.
  unfold or_code_mask.
  unfold COMP_BITS_NO. unfold OFFSET_BITS_NO.
  reflexivity. Qed.

Example test_or_code_mask3 :
  or_code_mask 3%N = (hex2N "003000").
Proof.
  unfold or_code_mask.
  unfold COMP_BITS_NO. unfold OFFSET_BITS_NO.
  reflexivity. Qed.

Example test_allocate_data_slots0 :
  Allocator.allocate_data_slots 0 = [].
Proof.
  unfold Allocator.allocate_data_slots.
  reflexivity. Qed.

Example test_allocate_data_slots5 :
  Allocator.allocate_data_slots 5 = [3%N;5%N;7%N;9%N;11%N].
Proof.
  unfold Allocator.allocate_data_slots.
  reflexivity. Qed.

Example test_allocate_code_slots0 :
  Allocator.allocate_code_slots 0 = [].
Proof.
  unfold Allocator.allocate_code_slots.
  reflexivity. Qed.

Example test_allocate_code_slots5 :
  Allocator.allocate_code_slots 5 = [0%N;2%N;4%N;6%N;8%N].
Proof.
  unfold Allocator.allocate_code_slots.
  reflexivity. Qed.

Example test_get_register :
   RiscMachine.RegisterFile.get_register RiscMachine.Register.R_SFI_SP (List.map Z.of_nat (List.seq 0 RiscMachine.Register.NO_REGISTERS)) = Some 26%Z.
Proof.
  unfold RiscMachine.RegisterFile.get_register.
  unfold RiscMachine.Register.R_SFI_SP.
  unfold  RiscMachine.Register.NO_REGISTERS.
  reflexivity. Qed.


(************************************************************************)
(* Copyright (c) 2017, Ajay Kumar Eeralla <ae266@mail.missouri.edu>     *)
(*                   University of Missouri-Columbia.                   *)
(*                                                                      *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

Load "ex5_4_IFTF".

(** This library defines a theorem [IFIDEMP] and its proof. Notice that we use [#] (resp. [##]) for [message] (resp. [Bool]) in lieu of [=].

 [if b then (if b then x1 else y1) else (if b then x2 else y2) # if b then x1 else y2] *)

Theorem IFIDEMP_B : forall (n: nat)(b1 b2 b3 b4 : Bool), (ifb (Bvar n) (ifb (Bvar n) b1 b2) (ifb (Bvar n) b3 b4)) ## (ifb (Bvar n) b1 b4).
Proof.
intros n b1 b2 b3 b4.
rewrite IFEVAL_B with (b1:= ifb (Bvar n) b1 b2)(b2 := (ifb (Bvar n) b3 b4)) .
simpl.
rewrite <-beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_B with(b2:=b4).
reflexivity.
Qed.

Theorem IFIDEMP_M : forall (n: nat)(x1 x2 y1 y2 : message),  (ifm (Bvar n) (ifm (Bvar n) x1 y1) (ifm (Bvar n) x2 y2)) # (ifm (Bvar n) x1 y2).
Proof.
intros n x1 x2 y1 y2 .
rewrite IFEVAL_M with (t1:= ifm (Bvar n) x1 y1)(t2 := (ifm (Bvar n) x2 y2)) .
simpl.
rewrite <-beq_nat_refl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
rewrite IFEVAL_M with (t2:=y2).
reflexivity.
Qed.


Definition classic:Prop:=
forall p:Prop,
~~p->p.
Definition xmid:Prop:=
forall p:Prop,
p\/~p.
Definition peirce:Prop:=
forall p q:Prop,
((p->q)->p)->p.

Definition imply_to_or:Prop:=
forall p q:Prop,
(p->q)->(~p\/q).
Definition dm:Prop:=
forall p q:Prop,
~(~p/\~q)->p\/q.

Theorem c_x:classic<->xmid.
unfold classic,xmid.
split.
intros.
apply H.
intro.
apply H0.
left.
apply H.
intro.
apply H0.
right.
intro.
apply H1.
exact H2.
intros.
elim (H p).
auto.
intro.
elim H0.
exact H1.
Qed.

Theorem cp:
classic<->peirce.
unfold classic,peirce.
split.
intros.
apply H.
intro.
apply H1.
apply H0.
intros.
elim H1.
exact H2.
intros.
apply (H _ False).
intros.
elim H0.
exact H1.
Qed.

Theorem ci:classic<->imply_to_or.
unfold classic,imply_to_or.
split.
intros.
apply H.
intro.
apply H1.
left.
intro.
apply H1.
right.
exact (H0 H2).
intros.
elim (H p p).
intro.
elim H0.
exact H1.
auto.
auto.
Qed.

Theorem cd:classic<->dm.

unfold classic,dm.
split.
intros.
apply H.
intro.
info apply H0.
split.
intro.
apply H1.
info left.
exact H2.

intro.
apply H1.
right.
exact H2.

intros.
elim (H p p).
auto.
auto.
intro.
apply H0.
exact (proj1 H1).
Qed.

Axiom (Cat:Type).
Axiom (Object:Type).

Definition Functor(C D:Cat):=Object->Object.

Axiom (incl:Object->Cat->Prop).

Axiom (eff :forall C D:Cat,Functor C D->Object->Object).

Definition universal(C D:Cat)(U:Functor D C)(X:Object)(_:incl X C)
(A:Object)(_:incl A (eff D C U A)):Prop.


Require Export basic_matroid_list.
Require Import Lia.

Parameter rk_singleton_ge : forall A, rk (A :: nil)  >= 1.
Parameter rk_couple_ge : forall A B, ~ A = B -> rk(A :: B :: nil) >= 2.
Parameter rk_three_points_on_lines : forall A B, exists C, rk (A :: B :: C :: nil) = 2 /\ rk (B :: C :: nil) = 2 /\ rk (A :: C :: nil) = 2.
Parameter rk_inter : forall A B C D, rk(A :: B :: C :: D :: nil) <= 3 -> exists J : Point, rk(A :: B :: J :: nil) = 2 /\ rk (C :: D :: J :: nil) = 2.
Parameter rk_lower_dim : exists A0 A1 A2 A3, rk( A0 :: A1 :: A2 :: A3 :: nil) = 4.
Parameter rk_upper_dim : forall e, rk(e) <= 4.

Lemma rk_singleton_1 : forall A, rk(A :: nil) <= 1.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_singleton : forall A, rk(A :: nil) = 1.
Proof.
intros.
assert(H := rk_singleton_ge A).
assert(HH := rk_singleton_1 A).
lia.
Qed.

Lemma matroid1_b_useful2 : forall (l : list Point) (a : Point), length (a :: l) >= 1 -> rk (a :: l) >= 1.
Proof.
intros.
assert(HH := rk_singleton a).
assert(HH0 := matroid2 (a :: nil) (a :: l)).
assert(HH1 : incl (a :: nil) (a :: l));[my_inO|].
assert(HH2 := HH0 HH1).
lia.
Qed.

Lemma rk_couple_2 : forall A B, rk(A :: B :: nil) <= 2.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_couple : forall A B : Point,~ A = B -> rk(A :: B :: nil) = 2.
Proof.
intros.
assert(HH := rk_couple_2 A B).
assert(HH0 := rk_couple_ge A B H).
lia.
Qed.

Lemma rk_triple_3 : forall A B C : Point, rk (A :: B :: C :: nil) <= 3.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma couple_rk1 : forall A B, rk(A :: B :: nil) = 2 -> ~ A = B.
Proof.
intros.
intro.
rewrite H0 in H.
assert(HH : equivlist (B :: B :: nil) (B :: nil));[my_inO|].
rewrite HH in H.
assert(HH0 := rk_singleton_1 B).
lia.
Qed.

Lemma couple_rk2 : forall A B, rk(A :: B :: nil) = 1 -> A = B.
Proof.
intros.
case_eq(eq_dec A B).
intros.
assumption.
intros.
assert(HH := rk_couple A B n).
lia.
Qed.

Lemma rule_1 : forall A B AiB, forall MA MB mAiB,
rk(A) <= MA -> rk(B) <= MB -> rk(AiB) >= mAiB -> incl AiB (list_inter A B) ->
rk(A ++ B) <= MA + MB - mAiB.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
lia.
Qed.

Lemma rule_2 : forall A B AiB, forall mAuB mAiB MB,
rk(A ++ B) >= mAuB -> rk(AiB) >= mAiB -> rk(B) <= MB -> incl AiB (list_inter A B) ->
rk(A) >= mAuB + mAiB - MB.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
lia.
Qed.

Lemma rule_3 : forall A B AiB, forall MA MB mAuB,
rk(A) <= MA -> rk(B) <= MB -> rk(A ++ B) >= mAuB -> incl AiB (list_inter A B) ->
rk(AiB) <= MA + MB - mAuB.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
lia.
Qed.

Lemma rule_4 : forall A B AiB, forall mAuB mAiB MA,
rk(A ++ B) >= mAuB -> rk(AiB) >= mAiB -> rk(A) <= MA -> incl AiB (list_inter A B) ->
rk(B) >= mAuB + mAiB - MA.
Proof.
intros.
assert(HH := matroid3_useful A B AiB H2).
lia.
Qed.

Lemma rule_5 : forall A B, forall mA mB,
rk(A) >= mA -> mA >= mB -> incl A B ->
rk(B) >= mA.
Proof.
intros.
assert(HH := matroid2 A B H1).
lia.
Qed.

Lemma rule_6 : forall A B, forall MA MB,
rk(B) <= MB -> MB <= MA -> incl A B ->
rk(A) <= MB.
Proof.
intros.
assert(HH := matroid2 A B H1).
lia.
Qed.

Lemma rule_7 : forall A B, forall mA mB,
rk(B) >= mB -> mB >= mA -> incl B A ->
rk(A) >= mB.
Proof.
intros.
assert(HH := matroid2 B A H1).
lia.
Qed.

Lemma rule_8 : forall A B, forall MA MB,
rk(A) <= MA -> MA <= MB -> incl B A ->
rk(B) <= MA.
Proof.
intros.
assert(HH := matroid2 B A H1).
lia.
Qed.

Parameter rk_pappus : forall A B C D E F G H I,
rk(A :: B :: nil) = 2 -> rk(A :: C :: nil) = 2 -> rk(A :: D :: nil) = 2 ->
rk(A :: E :: nil) = 2 -> rk(A :: F :: nil) = 2 ->
rk(B :: C :: nil) = 2 -> rk(B :: D :: nil) = 2 -> rk(B :: E :: nil) = 2 ->
rk(B :: F :: nil) = 2 ->
rk(C :: D :: nil) = 2 -> rk(C :: E :: nil) = 2 -> rk(C :: F :: nil) = 2 ->
rk(D :: E :: nil) = 2 -> rk(D :: F :: nil) = 2 ->
rk(E :: F :: nil) = 2 ->
rk(A :: B :: C :: nil) = 2 -> rk(D :: E :: F :: nil) = 2 ->
rk(A :: E :: G :: nil) = 2 -> rk(B :: D :: G :: nil) = 2 ->
rk(A :: F :: H :: nil) = 2 -> rk(C :: D :: H :: nil) = 2 ->
rk(B :: F :: I :: nil) = 2 -> rk(C :: E :: I :: nil) = 2 -> rk(G :: H :: I :: nil) = 2.

Ltac rk_couple_triple :=
  match goal with

| H : rk(?A :: ?B :: nil) = 2 |- rk(?A :: ?B :: nil) = 2 => assumption
| H : rk(?B :: ?A :: nil) = 2 |- rk(?A :: ?B :: nil) = 2 => rewrite couple_equal in H;assumption

| H : rk(?A :: ?B :: ?C :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => assumption
| H : rk(?A :: ?C :: ?B :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_1 in H;assumption
| H : rk(?B :: ?A :: ?C :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_2 in H;assumption
| H : rk(?B :: ?C :: ?A :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_3 in H;assumption
| H : rk(?C :: ?A :: ?B :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_4 in H;assumption
| H : rk(?C :: ?B :: ?A :: nil) = _ |-  rk(?A :: ?B :: ?C :: nil) = _ => rewrite <-triple_equal_5 in H;assumption
end.


Set Implicit Arguments.

Definition compose : forall A B C:Type, (A->B)->(B->C)->A->C :=
    (fun A B C f g x => g (f x)).

Print compose.
Theorem compose_assoc: forall (A B C D:Type)(f: A->B)(g:B->C)(h:C->D),
  compose f (compose g h) = compose (compose f g) h.
Proof.
  intros A B C D f g h.
  reflexivity.
Qed.


(** **********************************************************

Anders Mörtberg, 2016

************************************************************)

(** **********************************************************

Contents:

- Definition of the functors given by binary product with
  a fixed object
- Definition of exponentials

Section [ExponentialsCarriedThroughAdjointEquivalence] added by Ralph Matthes in 2023

************************************************************)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.limits.binproducts.

(* for Section [ExponentialsCarriedThroughAdjointEquivalence] *)
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.limits.Preservation.
Require Import UniMath.CategoryTheory.catiso.
Require Import UniMath.CategoryTheory.CategoryEquality.
Require Import UniMath.CategoryTheory.Core.Univalence.

Local Open Scope cat.

Section exponentials.

Context {C : category} (PC : BinProducts C).

(* The functor "a * _" and "_ * a" *)
Definition constprod_functor1 (a : C) : functor C C :=
  BinProduct_of_functors C C PC (constant_functor C C a) (functor_identity C).

Definition constprod_functor2 (a : C) : functor C C :=
  BinProduct_of_functors C C PC (functor_identity C) (constant_functor C C a).

Definition is_exponentiable (a : C) : UU := is_left_adjoint (constprod_functor1 a).

Definition Exponentials : UU := ∏ (a : C), is_exponentiable a.
Definition hasExponentials : UU := ∏ (a : C), ∥ is_exponentiable a ∥.

Definition nat_trans_constprod_functor1 (a : C) :
  nat_trans (constprod_functor1 a) (constprod_functor2 a).
Proof.
use tpair.
- intro x; simpl; unfold BinProduct_of_functors_ob; simpl.
  apply BinProductArrow; [ apply BinProductPr2 | apply BinProductPr1 ].
- abstract (intros x y f; simpl; unfold BinProduct_of_functors_mor; simpl;
  eapply pathscomp0; [apply precompWithBinProductArrow|];
  apply pathsinv0; eapply pathscomp0; [apply postcompWithBinProductArrow|];
  now rewrite (BinProductOfArrowsPr2 C _ (PC a x)), (BinProductOfArrowsPr1 C _ (PC a x))).
Defined.

Definition nat_trans_constprod_functor2 (a : C) :
  nat_trans (constprod_functor2 a) (constprod_functor1 a).
Proof.
use tpair.
- intro x; simpl; unfold BinProduct_of_functors_ob; simpl.
  apply BinProductArrow; [ apply BinProductPr2 | apply BinProductPr1 ].
- abstract (intros x y f; simpl; unfold BinProduct_of_functors_mor; simpl;
  eapply pathscomp0; [apply precompWithBinProductArrow|];
  apply pathsinv0; eapply pathscomp0; [apply postcompWithBinProductArrow|];
  now rewrite (BinProductOfArrowsPr2 C _ (PC x a)), (BinProductOfArrowsPr1 C _ (PC x a))).
Defined.

Lemma is_z_iso_constprod_functor1 a :
  @is_z_isomorphism [C,C] _ _ (nat_trans_constprod_functor1 a).
Proof.
  exists (nat_trans_constprod_functor2 a).
  split.
  + abstract (
    apply (nat_trans_eq C); intro x; simpl; unfold BinProduct_of_functors_ob; simpl;
    eapply pathscomp0; [apply precompWithBinProductArrow|];
    now rewrite BinProductPr1Commutes, BinProductPr2Commutes, BinProductArrowEta, !id_left).
  + abstract (
    apply (nat_trans_eq C); intro x; simpl; unfold BinProduct_of_functors_ob; simpl;
    eapply pathscomp0; [apply precompWithBinProductArrow|];
    now rewrite BinProductPr1Commutes, BinProductPr2Commutes, BinProductArrowEta, !id_left).
Defined.

(* This is not used *)
Lemma is_z_iso_constprod_functor2 a :
  @is_z_isomorphism [C,C] _ _ (nat_trans_constprod_functor2 a).
Proof.
  exists (nat_trans_constprod_functor1 a).
  split.
  + abstract (
        apply (nat_trans_eq C); intro x; simpl; unfold BinProduct_of_functors_ob; simpl;
        eapply pathscomp0; [apply precompWithBinProductArrow|];
        now rewrite BinProductPr1Commutes, BinProductPr2Commutes, BinProductArrowEta, !id_left).
  + abstract (
        apply (nat_trans_eq C); intro x; simpl; unfold BinProduct_of_functors_ob; simpl;
        eapply pathscomp0; [apply precompWithBinProductArrow|];
        now rewrite BinProductPr1Commutes, BinProductPr2Commutes, BinProductArrowEta, !id_left).
Defined.

Definition flip_z_iso a : @z_iso [C,C] (constprod_functor1 a) (constprod_functor2 a) :=
  tpair _ _ (is_z_iso_constprod_functor1 a).

Variable (a : C).
Variable (HF : is_left_adjoint (constprod_functor1 a)).

Local Notation F := (constprod_functor1 a).
Local Notation F' := (constprod_functor2 a).
Let G := right_adjoint HF.
Let H := pr2 HF : are_adjoints F G.
Let eta : [C,C]⟦functor_identity C,functor_composite F G⟧ := unit_from_left_adjoint H.
Let eps : [C,C]⟦functor_composite G F,functor_identity C⟧ := counit_from_left_adjoint H.
Let H1 := triangle_id_left_ad H.
Let H2 := triangle_id_right_ad H.

Arguments constprod_functor1 : simpl never.
Arguments constprod_functor2 : simpl never.
Arguments flip_z_iso : simpl never.

Local Definition eta' : [C,C]⟦functor_identity C,functor_composite F' G⟧ :=
  let G' := (post_composition_functor C C C G)
  in eta · (# G' (flip_z_iso a)).

Local Definition eps' : [C,C]⟦functor_composite G F',functor_identity C⟧ :=
  let G' := (pre_composition_functor C C C G)
  in # G' (inv_from_z_iso (flip_z_iso a)) · eps.

Local Lemma form_adjunction_eta'_eps' : form_adjunction F' G eta' eps'.
Proof.
fold eta in H1; fold eps in H1; fold eta in H2; fold eps in H2; fold G in H2.
use tpair.
+ intro x; unfold eta', eps'; cbn.
  rewrite assoc.
  eapply pathscomp0.
  - eapply cancel_postcomposition.
    exact (nat_trans_ax (inv_from_z_iso (flip_z_iso _)) _ _ _).
  - rewrite functor_comp, assoc.
    eapply pathscomp0; [rewrite <- assoc; apply maponpaths, (nat_trans_ax eps)|].
    rewrite <- assoc.
    eapply pathscomp0; [apply maponpaths; rewrite assoc; apply cancel_postcomposition, H1|].
    rewrite id_left.
    apply (nat_trans_eq_pointwise (z_iso_after_z_iso_inv (flip_z_iso a)) x).
+ intro x; cbn.
  rewrite <- (H2 x), <- assoc, <- (functor_comp G).
  apply maponpaths, maponpaths.
  rewrite assoc.
  apply remove_id_left; try apply idpath.
  apply (nat_trans_eq_pointwise (z_iso_inv_after_z_iso (flip_z_iso a))).
Qed.

Lemma is_left_adjoint_constprod_functor2 : is_left_adjoint F'.
Proof.
apply (tpair _ G).
apply (tpair _ (make_dirprod eta' eps')).
apply form_adjunction_eta'_eps'.
Defined.

End exponentials.

Section ExponentialsCarriedThroughAdjointEquivalence.

  Context {C : category} (PC : BinProducts C) {D : category} (PD : BinProducts D)
    (ExpC : Exponentials PC) (adjeq : adj_equiv C D).

  Let F : functor C D := adjeq.
  Let G : functor D C := adj_equivalence_inv adjeq.
  Let η_z_iso : ∏ (c : C), z_iso c (G (F c)) := unit_pointwise_z_iso_from_adj_equivalence adjeq.
  Let ε_z_iso : ∏ (d : D), z_iso (F (G d)) d := counit_pointwise_z_iso_from_adj_equivalence adjeq.
  Let η_nat_z_iso : nat_z_iso (functor_identity C) (functor_composite F G) :=
        unit_nat_z_iso_from_adj_equivalence_of_cats adjeq.
  Let ε_nat_z_iso : nat_z_iso  (functor_composite G F) (functor_identity D) :=
        counit_nat_z_iso_from_adj_equivalence_of_cats adjeq.

  Let FC (c : C) : functor C C := constprod_functor1 PC c.
  Let GC (c : C) : functor C C := right_adjoint (ExpC c).
  Let ηC (c : C) : functor_identity C ⟹ (FC c) ∙ (GC c) := unit_from_left_adjoint (ExpC c).
  Let εC (c : C) : functor_composite (GC c) (FC c) ⟹ functor_identity C := counit_from_left_adjoint (ExpC c).

Section FixAnObject.

  Context (d0 : D).

  Let Fd0 : functor D D := constprod_functor1 PD d0.
  Let Gd0 : functor D D := functor_composite (functor_composite G (GC (G d0))) F.

Local Definition inherited_BP_on_C (d : D) : BinProduct C (G d0) (G d).
Proof.
  use tpair.
  - exists (G (pr1 (pr1 (PD d0 d)))).
    exact (# G (pr1 (pr2 (pr1 (PD d0 d)))),,# G (pr2 (pr2 (pr1 (PD d0 d))))).
  - set (Hpres := right_adjoint_preserves_binproduct adjeq adjeq : preserves_binproduct G).
    exact (Hpres _ _ _ _ _ (pr2 (PD d0 d))).
Defined.

Local Definition μ_nat_trans_data : nat_trans_data (G ∙ FC (G d0)) (Fd0 ∙ G).
Proof.
  intro d.
  exact (BinProductOfArrows _ (inherited_BP_on_C d) (PC (G d0) (G d)) (identity _) (identity _)).
Defined.

Local Lemma μ_nat_trans_law : is_nat_trans _ _ μ_nat_trans_data.
Proof.
  intros d' d f.
  apply (BinProductArrowsEq _ _ _ (inherited_BP_on_C d)).
  - etrans.
    { rewrite assoc'.
      apply maponpaths.
      apply (BinProductOfArrowsPr1 _ (inherited_BP_on_C d) (PC (G d0) (G d))). }
    rewrite id_right.
    etrans.
    2: { cbn.
         rewrite assoc'.
         etrans.
         2: { apply maponpaths.
              apply functor_comp. }
         unfold BinProduct_of_functors_mor.
         cbn.
         etrans.
         2: { do 2 apply maponpaths.
              apply pathsinv0, BinProductOfArrowsPr1. }
         rewrite id_right.
         unfold BinProductPr1.
         apply pathsinv0, (BinProductOfArrowsPr1 _ (inherited_BP_on_C d') (PC (G d0) (G d'))).
    }
    rewrite id_right.
    cbn.
    unfold BinProduct_of_functors_mor, constant_functor, functor_identity.
    cbn.
    etrans.
    { apply (BinProductOfArrowsPr1 _ (PC (G d0) (G d)) (PC (G d0) (G d'))). }
    apply id_right.
  - etrans.
    { rewrite assoc'.
      apply maponpaths.
      apply (BinProductOfArrowsPr2 _ (inherited_BP_on_C d) (PC (G d0) (G d))). }
    rewrite id_right.
    etrans.
    2: { cbn.
         rewrite assoc'.
         etrans.
         2: { apply maponpaths.
              apply functor_comp. }
         unfold BinProduct_of_functors_mor.
         cbn.
         etrans.
         2: { do 2 apply maponpaths.
              apply pathsinv0, BinProductOfArrowsPr2. }
         rewrite functor_comp.
         rewrite assoc.
         apply cancel_postcomposition.
         unfold BinProductPr2.
         apply pathsinv0, (BinProductOfArrowsPr2 _ (inherited_BP_on_C d') (PC (G d0) (G d'))).
    }
    rewrite id_right.
    cbn.
    unfold BinProduct_of_functors_mor, constant_functor, functor_identity.
    cbn.
    etrans.
    { apply (BinProductOfArrowsPr2 _ (PC (G d0) (G d)) (PC (G d0) (G d'))). }
    apply idpath.
Qed.

Local Definition μ_nat_trans : nat_trans (G ∙ FC (G d0)) (Fd0 ∙ G) := _,,μ_nat_trans_law.

Local Definition μ_nat_trans_inv_pointwise (d : D) : C ⟦ (Fd0 ∙ G) d, (G ∙ FC (G d0)) d ⟧.
Proof.
  exact (BinProductOfArrows _ (PC (G d0) (G d)) (inherited_BP_on_C d) (identity _) (identity _)).
Defined.

Local Lemma μ_nat_trans_is_inverse (d : D): is_inverse_in_precat (μ_nat_trans d) (μ_nat_trans_inv_pointwise d).
Proof.
  split; cbn.
  - apply pathsinv0, BinProduct_endo_is_identity.
    + rewrite assoc'.
      etrans.
      { apply maponpaths.
        cbn.
        apply (BinProductOfArrowsPr1 _ (PC (G d0) (G d)) (inherited_BP_on_C d)). }
      rewrite id_right.
      etrans.
      { cbn.
        apply (BinProductOfArrowsPr1 _ (inherited_BP_on_C d) (PC (G d0) (G d))). }
      apply id_right.
    + rewrite assoc'.
      etrans.
      { apply maponpaths.
        cbn.
        apply (BinProductOfArrowsPr2 _ (PC (G d0) (G d)) (inherited_BP_on_C d)). }
      rewrite id_right.
      etrans.
      { cbn.
        apply (BinProductOfArrowsPr2 _ (inherited_BP_on_C d) (PC (G d0) (G d))). }
      apply id_right.
  - unfold BinProduct_of_functors_ob, constant_functor, functor_identity.
    cbn.
    apply pathsinv0. apply (BinProduct_endo_is_identity _ _ _ (inherited_BP_on_C d)).
    + rewrite assoc'.
      etrans.
      { apply maponpaths.
        apply (BinProductOfArrowsPr1 _ (inherited_BP_on_C d) (PC (G d0) (G d))). }
      rewrite id_right.
      etrans.
      { apply (BinProductOfArrowsPr1 _ (PC (G d0) (G d)) (inherited_BP_on_C d)). }
      apply id_right.
    + rewrite assoc'.
      etrans.
      { apply maponpaths.
        apply (BinProductOfArrowsPr2 _ (inherited_BP_on_C d) (PC (G d0) (G d))). }
      rewrite id_right.
      etrans.
      { apply (BinProductOfArrowsPr2 _ (PC (G d0) (G d)) (inherited_BP_on_C d)). }
      apply id_right.
Qed.

Local Definition μ : nat_z_iso (functor_composite G (FC (G d0))) (functor_composite Fd0 G).
Proof.
  use make_nat_z_iso.
  - exact μ_nat_trans.
  - intro d.
    use tpair.
    + exact (μ_nat_trans_inv_pointwise d).
    + exact (μ_nat_trans_is_inverse d).
Defined.

Local Definition ηDd0 : functor_identity D ⟹ Fd0 ∙ Gd0.
Proof.
  simple refine (nat_trans_comp _ _ _ (nat_z_iso_to_trans_inv ε_nat_z_iso) _).
  unfold Gd0.
  change ((functor_composite G (functor_identity C)) ∙ F ⟹ (Fd0 ∙ (G ∙ GC (G d0))) ∙ F).
  apply post_whisker.
  refine (nat_trans_comp _ _ _ _ _).
  - apply (pre_whisker G (ηC (G d0))).
  - change (functor_composite (functor_composite G (FC (G d0))) (GC (G d0)) ⟹
              functor_composite (Fd0 ∙ G) (GC (G d0))).
    apply post_whisker.
    apply μ.
Defined.

Local Definition εDd0 : Gd0 ∙ Fd0 ⟹ functor_identity D.
Proof.
  simple refine (nat_trans_comp _ _ _ _ ε_nat_z_iso).
  change (functor_composite (functor_composite Gd0 Fd0) (functor_identity D) ⟹ G ∙ F).
  refine (nat_trans_comp _ _ _ _ _).
  - apply (pre_whisker _ (nat_z_iso_to_trans_inv ε_nat_z_iso)).
  - change ((functor_composite (Gd0 ∙ Fd0) G) ∙ F ⟹ G ∙ F).
    apply post_whisker.
    unfold Gd0.
    change (((G ∙ GC (G d0)) ∙ F) ∙ (Fd0 ∙ G) ⟹ G).
    refine (nat_trans_comp _ _ _ _ _).
    + apply (pre_whisker _ (nat_z_iso_to_trans_inv μ)).
    + change ((((G ∙ GC (G d0)) ∙ F) ∙ G) ∙ FC (G d0) ⟹ G).
      refine (nat_trans_comp _ _ _ _ _).
      * use (post_whisker _ (FC (G d0))).
        -- exact (G ∙ GC (G d0)).
        -- change (functor_composite (G ∙ GC (G d0)) (functor_composite F G) ⟹
                     functor_composite (G ∙ GC (G d0)) (functor_identity C)).
           apply (pre_whisker _ (nat_z_iso_to_trans_inv η_nat_z_iso)).
      * change (functor_composite G (functor_composite (GC (G d0)) (FC (G d0))) ⟹ G).
        apply (pre_whisker _ (εC (G d0))).
Defined.

Definition is_expDd0_adjunction_data : adjunction_data D D.
Proof.
  use make_adjunction_data.
  - exact Fd0.
  - exact Gd0.
  - exact ηDd0.
  - exact εDd0.
Defined.

Lemma is_expDd0_adjunction_laws : form_adjunction' is_expDd0_adjunction_data.
Proof.
  split.
  - intro d.
    change (# Fd0 (ηDd0 d) · εDd0 (Fd0 d) = identity (Fd0 d)).
    unfold ηDd0.
    etrans.
    { apply cancel_postcomposition.
      etrans.
      { apply functor_comp. }
      do 2 apply maponpaths.
      assert (Hpost := post_whisker_composition _ _ _ F _ _ _ (pre_whisker G (ηC (G d0))) (post_whisker (pr1 μ) (GC (G d0)))).
      refine (toforallpaths _ _ _ (maponpaths pr1 Hpost) d).
    }
    etrans.
    { apply cancel_postcomposition.
      apply maponpaths.
      apply functor_comp. }
    unfold εDd0.
(* so it is in principle possible to work with this definition, but every step takes an effort,
   requiring a perfect proof on paper before

    rewrite functor_comp.
    use BinProductArrowsEq.
    + rewrite id_left.

      cbn. unfold BinProduct_of_functors_mor.
      rewrite id_left.
      unfold BinProduct_of_functors_ob, constant_functor, functor_identity.
      cbn.
      etrans.
      { apply cancel_postcomposition.
        apply
      admit.
    + cbn. unfold BinProduct_of_functors_mor.
      rewrite id_left.
      unfold BinProduct_of_functors_ob, constant_functor, functor_identity.
      cbn.
      (* is this supposed to be analogous? *)
      admit.
  - intro d. show_id_type. (* F-images in source and target of the morphisms *)
    cbn.
    admit.
*)
Abort.

(*
Definition is_expDd0_adjunction : adjunction D D := _,,is_expDd0_adjunction_laws.

Local Definition is_expDd0 : is_exponentiable PD d0.
Proof.
  exists Gd0.
  exact is_expDd0_adjunction.
Defined.
 *)

(* an experiment towards using univalence for this proof
Lemma is_expDd0_adjunction_laws_equal_cats (Heq : C = D) (*(PCeq : transportf _ Heq PC = PD)*) :
  form_adjunction' is_expDd0_adjunction_data.
Proof.
  induction Heq.
*)

End FixAnObject.
(*
Definition exponentials_through_adj_equivalence : Exponentials PD.
Proof.
  intro d0. exact (is_expDd0 d0).
Defined.
 *)

End ExponentialsCarriedThroughAdjointEquivalence.

Section AlternativeWithUnivalence.

  Context {C : category} (PC : BinProducts C) {D : category} (PD : BinProducts D)
    (ExpC : Exponentials PC) (adjeq : adj_equiv C D) (Cuniv : is_univalent C) (Duniv : is_univalent D).

  Local Lemma CDeq : C = D.
  Proof.
    assert (aux : category_to_precategory C = category_to_precategory D).
    { apply (invmap (catiso_is_path_precat C D D)).
      apply (adj_equivalence_of_cats_to_cat_iso adjeq); assumption. }
    apply subtypePath. intro. apply isaprop_has_homsets.
    exact aux.
  Qed.

  Definition exponentials_through_adj_equivalence_univalent_cats : Exponentials PD.
  Proof.
    induction CDeq.
    clear adjeq.
    assert (aux : PC = PD).
    2: { rewrite <- aux. exact ExpC. }
    apply funextsec.
    intro c1.
    apply funextsec.
    intro c2.
    apply isaprop_BinProduct; exact Cuniv.
  Defined.

End AlternativeWithUnivalence.

(**
 Accessors for exponentials
 *)
Section AccessorsExponentials.
  Context {C : category}
          {prodC : BinProducts C}
          (expC : Exponentials prodC).

  Definition exp
             (x y : C)
    : C
    := pr1 (expC x) y.

  Definition exp_eval
             (x y : C)
    : prodC x (exp x y) --> y
    := counit_from_are_adjoints (pr2 (expC x)) y.

  Definition exp_eval_alt
             (x y : C)
    : prodC (exp x y) x --> y
    := prod_swap prodC _ _ · exp_eval x y.

  Definition exp_lam
             {x y z : C}
             (f : prodC y x --> z)
    : x --> exp y z
    := unit_from_are_adjoints (pr2 (expC y)) x · # (pr1 (expC y)) f.

  Definition exp_lam_alt
             {x y z : C}
             (f : prodC z x --> y)
    : z --> exp x y
    := exp_lam (prod_swap prodC _ _ · f).

  Proposition exp_beta
              {x y z : C}
              (f : prodC y x --> z)
    : BinProductOfArrows _ _ _ (identity _) (exp_lam f)
      · exp_eval _ _
      =
      f.
  Proof.
    unfold exp_lam.
    rewrite <- BinProductOfArrows_idxcomp.
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      exact (nat_trans_ax
              (counit_from_are_adjoints (pr2 (expC y)))
              _
              _
              f).
    }
    cbn.
    rewrite !assoc.
    refine (_ @ id_left _).
    apply maponpaths_2.
    apply (triangle_id_left_ad (pr2 (expC y))).
  Qed.

  Proposition exp_beta_alt
              {x y z : C}
              (f : prodC z x --> y)
    : BinProductOfArrows _ _ _ (exp_lam_alt f) (identity x)
      · exp_eval_alt x y
      =
      f.
  Proof.
    unfold exp_eval_alt.
    rewrite !assoc.
    rewrite BinProductOfArrows_swap.
    unfold exp_lam_alt.
    rewrite !assoc'.
    rewrite exp_beta.
    rewrite !assoc.
    rewrite prod_swap_swap.
    apply id_left.
  Qed.

  Proposition exp_eta
              {x y z : C}
              (f : z --> exp x y)
    : f
      =
      exp_lam (BinProductOfArrows C _ _ (identity x) f · exp_eval x y).
  Proof.
    unfold exp_lam.
    rewrite functor_comp.
    rewrite !assoc.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      exact (!(nat_trans_ax
                 (unit_from_are_adjoints (pr2 (expC x)))
                 _
                 _
                 f)).
    }
    refine (_ @ id_right _).
    rewrite !assoc'.
    apply maponpaths.
    exact (triangle_id_right_ad (pr2 (expC x)) _).
  Qed.

  Proposition exp_eta_alt
              {x y z : C}
              (f : z --> exp x y)
    : f
      =
      exp_lam_alt (BinProductOfArrows C _ _ f (identity x) · exp_eval_alt x y).
  Proof.
    refine (exp_eta _ @ _).
    unfold exp_lam_alt.
    apply maponpaths.
    unfold exp_eval_alt.
    rewrite !assoc.
    apply maponpaths_2.
    rewrite !assoc'.
    rewrite BinProductOfArrows_swap.
    rewrite !assoc.
    rewrite prod_swap_swap.
    rewrite id_left.
    apply idpath.
  Qed.
End AccessorsExponentials.


Require Import Coq.ZArith.ZArith Coq.ZArith.BinIntDef.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Crypto.NewBaseSystem. Import B.
Require Import Crypto.ModularArithmetic.PrimeFieldTheorems.
Require Import Crypto.Util.Tactics Crypto.Util.Decidable.
Require Import Crypto.Util.LetIn Crypto.Util.ZUtil.
Require Crypto.Util.Tuple.
Local Notation tuple := Tuple.tuple.
Local Open Scope list_scope.
Local Open Scope Z_scope.
Local Coercion Z.of_nat : nat >-> Z.

(***
Modulus : 2^255-19
Base: 25.5
***)
Section Ops25p5.
  Local Infix "^" := tuple : type_scope.

  (* These definitions will need to be passed as Ltac arguments (or
  cleverly inferred) when things are eventually automated *)
  Definition wt := fun i : nat => 2^(25 * (i / 2) + 26 * ((i + 1) / 2)).
  Definition sz := 10%nat.
  Definition s : Z := 2^255.
  Definition c : list B.limb := [(1, 19)].
  Definition coef_div_modulus := 2. (* add 2*modulus before subtracting *)
  Definition carry_chain1 := Eval vm_compute in (seq 0 (pred sz)).
  Definition carry_chain2 := ([0;1])%nat.

  (* These definitions are inferred from those above *)
  Definition m := Eval vm_compute in Z.to_pos (s - Associational.eval c). (* modulus *)
  Definition sz2 := Eval vm_compute in ((sz * 2) - 1)%nat.
  Definition coef := Eval vm_compute in (@Positional.encode wt modulo div sz (coef_div_modulus * (s-Associational.eval c))). (* subtraction coefficient *)
  Definition coef_mod : mod_eq m (Positional.eval (n:=sz) wt coef) 0 := eq_refl.

  Lemma sz_nonzero : sz <> 0%nat. Proof. vm_decide. Qed.
  Lemma wt_nonzero i : wt i <> 0.
  Proof. apply Z.pow_nonzero; zero_bounds. Qed.
  Lemma wt_divides_chain1 i (H:In i carry_chain1) : wt (S i) / wt i <> 0.
  Proof.
    cbv [In carry_chain1] in H.
    repeat match goal with H : _ \/ _ |- _ => destruct H end;
      try (exfalso; assumption); subst; try vm_decide.
  Qed.
  Lemma wt_divides_chain2 i (H:In i carry_chain2) : wt (S i) / wt i <> 0.
  Proof.
    cbv [In carry_chain2] in H.
    repeat match goal with H : _ \/ _ |- _ => destruct H end;
      try (exfalso; assumption); subst; try vm_decide.
  Qed.
  Lemma wt_divides_full i : wt (S i) / wt i <> 0.
  Proof.
    cbv [wt].
    match goal with |- _ ^ ?x / _ ^ ?y <> _ => assert (0 <= y <= x) end.
    { rewrite Nat2Z.inj_succ. split; [zero_bounds|].
    apply Z.add_le_mono;
      (apply Z.mul_le_mono_nonneg_l; [zero_bounds|]);
      apply Z.div_le_mono; omega. }
    rewrite <-Z.pow_sub_r by omega.
    apply Z.pow_nonzero; omega.
  Qed.

  Definition zero_sig :
    { zero : Z^sz | Positional.Fdecode (m:=m) wt zero = 0%F}.
  Proof.
    let t := eval vm_compute in
    (Positional.encode (n:=sz) (modulo:=modulo) (div:=div) wt 0) in
        exists t; vm_decide.
  Defined.

  Definition one_sig :
    { one : Z^sz | Positional.Fdecode (m:=m) wt one = 1%F}.
  Proof.
    let t := eval vm_compute in
    (Positional.encode (n:=sz) (modulo:=modulo) (div:=div) wt 1) in
        exists t; vm_decide.
  Defined.

  Definition add_sig :
    { add : (Z^sz -> Z^sz -> Z^sz)%type |
               forall a b : Z^sz,
                 let eval := Positional.Fdecode (m:=m) wt in
                 eval (add a b) = (eval a  + eval b)%F }.
  Proof.
    eexists; cbv beta zeta; intros.
    pose proof wt_nonzero.
    let x := constr:(
        Positional.add_cps (n := sz) wt a b id) in
    solve_op_F wt x. reflexivity.
  Defined.

  Definition sub_sig :
    {sub : (Z^sz -> Z^sz -> Z^sz)%type |
               forall a b : Z^sz,
                 let eval := Positional.Fdecode (m:=m) wt in
                 eval (sub a b) = (eval a - eval b)%F}.
  Proof.
    eexists; cbv beta zeta; intros.
    pose proof wt_nonzero.
    let x := constr:(
         Positional.sub_cps (n:=sz) (coef := coef) wt a b id) in
    solve_op_F wt x. reflexivity.
  Defined.

  Definition opp_sig :
    {opp : (Z^sz -> Z^sz)%type |
               forall a : Z^sz,
                 let eval := Positional.Fdecode (m := m) wt in
                 eval (opp a) = F.opp (eval a)}.
  Proof.
    eexists; cbv beta zeta; intros.
    pose proof wt_nonzero.
    let x := constr:(
         Positional.opp_cps (n:=sz) (coef := coef) wt a id) in
    solve_op_F wt x. reflexivity.
  Defined.

  Definition mul_sig :
    {mul : (Z^sz -> Z^sz -> Z^sz)%type |
               forall a b : Z^sz,
                 let eval := Positional.Fdecode (m := m) wt in
                 eval (mul a b) = (eval a  * eval b)%F}.
  Proof.
    eexists; cbv beta zeta; intros.
    pose proof wt_nonzero.
    let x := constr:(
         Positional.mul_cps (n:=sz) (m:=sz2) wt a b
           (fun ab => Positional.reduce_cps (n:=sz) (m:=sz2) wt s c ab id)) in
    solve_op_F wt x. reflexivity.

    (* rough breakdown of synthesis time *)
    (* 1.2s for side conditions -- should improve significantly when [chained_carries] gets a correctness lemma *)
    (* basesystem_partial_evaluation_RHS (primarily vm_compute): 1.8s, which gets re-computed during defined *)

    (* doing [cbv -[Let_In runtime_add runtime_mul]] took 37s *)

  Defined. (* 3s *)

  (* Performs a full carry loop (as specified by carry_chain) *)
  Definition carry_sig :
    {carry : (Z^sz -> Z^sz)%type |
               forall a : Z^sz,
                 let eval := Positional.Fdecode (m := m) wt in
                 eval (carry a) = eval a}.
  Proof.
    eexists; cbv beta zeta; intros.
    pose proof wt_nonzero. pose proof wt_divides_chain1.
    pose proof div_mod. pose proof wt_divides_chain2.
    let x := constr:(
               Positional.chained_carries_cps (n:=sz) (div:=div)(modulo:=modulo) wt a carry_chain1
                  (fun r => Positional.carry_reduce_cps (n:=sz) (div:=div) (modulo:=modulo) wt s c r
                  (fun rrr => Positional.chained_carries_cps (n:=sz) (div:=div) (modulo:=modulo) wt rrr carry_chain2 id
             ))) in
    solve_op_F wt x. reflexivity.
  Defined.

  Definition ring_25p5 :=
    (Ring.ring_by_isomorphism
         (F := F m)
         (H := Z^sz)
         (phi := Positional.Fencode wt)
         (phi' := Positional.Fdecode wt)
         (zero := proj1_sig zero_sig)
         (one := proj1_sig one_sig)
         (opp := proj1_sig opp_sig)
         (add := proj1_sig add_sig)
         (sub := proj1_sig sub_sig)
         (mul := proj1_sig mul_sig)
         (phi'_zero := proj2_sig zero_sig)
         (phi'_one := proj2_sig one_sig)
         (phi'_opp := proj2_sig opp_sig)
         (Positional.Fdecode_Fencode_id
            (sz_nonzero := sz_nonzero)
            (div_mod := div_mod)
            wt eq_refl wt_nonzero wt_divides_full)
         (Positional.eq_Feq_iff wt)
         (proj2_sig add_sig)
         (proj2_sig sub_sig)
         (proj2_sig mul_sig)
      ).

(*
Eval cbv [proj1_sig add_sig] in (proj1_sig add_sig).
Eval cbv [proj1_sig sub_sig] in (proj1_sig sub_sig).
Eval cbv [proj1_sig opp_sig] in (proj1_sig opp_sig).
Eval cbv [proj1_sig mul_sig] in (proj1_sig mul_sig).
Eval cbv [proj1_sig carry_sig] in (proj1_sig carry_sig).
*)

End Ops25p5.


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.
Require Import Tweetnacl.Libs.Term_Decidable.

Open Scope Z_scope.

Module TermOrder <: TotalLeBool.
    Definition t := term.
    Definition leb x y := term_leb x y.

    Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
    Proof.
      move=> a b.
      unfold leb, term_leb.
      destruct a, b.
      rewrite !Pos2Z.inj_leb.
      assert(H:= Zle_bool_total (Z.pos p) (Z.pos p0)).
      destruct H as [H|H] ; rewrite H ; auto.
      by right.
      by left.
      assert(H:= Zle_bool_total z z0).
      destruct H as [H|H] ; rewrite H ; auto.
    Qed.
End TermOrder.

Module ListTermOrder <: TotalLeBool.
  Definition t := list term.

  Fixpoint leb x y := match x, y with
    | nil , _ => true
    | _ , nil => false
    | a :: qa, b :: qb => match term_ltb a b with
      | true => true
      | false => match term_decide a b with
        | true => leb qa qb
        | false => false
        end
      end
  end.

  Theorem leb_total : forall a1 a2, leb a1 a2 = true \/ leb a2 a1 = true.
  Proof.
  elim => [| a qa IHa].
  by left.
  move=> [| b qb] ; simpl.
  by right.
  specialize IHa with qb ; simpl.
  destruct(term_ltb a b) eqn:H0 ; destruct(term_ltb b a) eqn:H1.
  by left.
  by left.
  by right.
  destruct(term_decide a b) eqn:H2; destruct(term_decide b a) eqn:H3.
  auto.
  move: H3 ; rewrite term_decide_com; congruence.
  move: H3 ; rewrite term_decide_com; congruence.
  exfalso.
  clear IHa.
  unfold term_ltb, term_decide in *.
  destruct a, b ; try discriminate.
  move: H2 ; rewrite Pos2Z.inj_eqb Z.eqb_neq.
  move: H0 ; rewrite Pos2Z.inj_ltb Z.ltb_ge.
  move: H1 ; rewrite Pos2Z.inj_ltb Z.ltb_ge.
  move => ? ? ?.
  omega.
  move: H2 ; rewrite Z.eqb_neq.
  move: H0 ; rewrite Z.ltb_ge.
  move: H1 ; rewrite Z.ltb_ge.
  move => ? ? ?.
  omega.
  Qed.
End ListTermOrder.

Module Import TermSort := Sort TermOrder.
Module Import ListTermSort := Sort ListTermOrder.

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

Section Expr.
  Inductive expr :=
    | R : term -> expr
    | A : expr -> expr -> expr
    | M : term -> term -> expr.

  Fixpoint expr_denote (env:environment) (m : expr) : Z :=
    match m with
    | R v   => denote env v
    | A x y => expr_denote env x + expr_denote env y
    | M x y => denote env x * denote env y
    end.

  Fixpoint latten_expr (e : expr) : (list (list term)) := match e with
    | A a b => latten_expr a ++ latten_expr b
    | M a b => (a :: b :: nil) :: nil
    | R x => (x :: nil) :: nil
  end.

  Fixpoint simplify_M (l: list term) : list term := match l with
    | nil => nil
    | Val 1 :: q => simplify_M q
    | h :: q => h :: simplify_M q
    end.

  Fixpoint ldenote_M (env:environment) (ls : list term) : Z :=
    match ls with
      | nil => 1
      | x :: ls' => denote env x * (ldenote_M env ls')
    end.

  Local Lemma ldenote_M_cons: forall (env:environment) a l, ldenote_M env (a::l) =  (denote env a) * ldenote_M env l.
  Proof. by move=> //. Qed.

  Local Lemma ldenote_M_app: forall (env:environment) a b, ldenote_M env (a ++ b) = ldenote_M env a * ldenote_M env b.
  Proof. induction a ; intros ; simpl => //.
  destruct (ldenote_M env b) ; auto.
  rewrite IHa ; ring.
  Qed.

  Local Lemma ldenote_M_simplify: forall (env:environment)  l, ldenote_M env l = ldenote_M env (simplify_M l).
  Proof. induction l as [|h l IHl] => //=.
  rewrite IHl. destruct h. by destruct p.
  destruct z ; try destruct p ; try reflexivity.
  simpl term_denote. ring.
  Qed.

  Local Lemma simplifiy_M_0 : forall (env:environment) a, existsb (decide (Val 0)) a = true -> ldenote_M env a = 0.
  Proof.
  induction a => //=.
  rewrite Bool.orb_true_iff => H.
  case H ; clear H => H.
  destruct a ; try discriminate.
  destruct z ; try discriminate.
  simpl term_denote ; omega.
  apply IHa in H ; rewrite H ; omega.
  Qed.

  Fixpoint simplify_A (l :list (list term)) : list (list term) := match l with
    | nil => nil
    | h :: q => let s := simplify_M h in
      match existsb (decide (Val 0)) s with
      | true => simplify_A q
      | false => s :: simplify_A q
      end
    end.

  Fixpoint ldenote (env:environment) (ls : list (list term)) : Z :=
    match ls with
      | nil => 0
      | x :: ls' => (ldenote_M env x) + (ldenote env ls')
    end.

  Local Lemma ldenote_cons: forall (env:environment) a l, ldenote env (a::l) = (ldenote_M env a) + ldenote env l.
  Proof. by move=> //. Qed.

  Local Lemma ldenote_app: forall (env:environment) a b, ldenote env (a ++ b) = ldenote env a + ldenote env b.
  Proof.
  induction a ; intros ; simpl => //.
  rewrite IHa ; ring.
  Qed.

  Local Lemma latten_expr_correct : forall (env:environment)  t, expr_denote env t = ldenote env (latten_expr t).
  Proof.
  induction t ; simpl ; try ring.
  rewrite ldenote_app IHt1 IHt2 => //.
  Qed.

  Local Lemma ldenote_simplify: forall (env:environment)  l, ldenote env l = ldenote env (simplify_A l).
  Proof. induction l ; intros ; simpl => //.
  destruct (existsb (term_decide (Val 0)) (simplify_M a)) eqn:H; auto.
  apply (simplifiy_M_0 env) in H.
  move: H ; rewrite -ldenote_M_simplify => -> ; omega.
  simpl; rewrite -?ldenote_M_simplify; omega.
  Qed.

  Definition flatten_expr t := simplify_A (latten_expr t).

  Local Lemma flatten_expr_correct : forall (env:environment) t, expr_denote env t = ldenote env (flatten_expr t).
  Proof. move => env t. unfold flatten_expr.
  rewrite -ldenote_simplify.
  apply latten_expr_correct.
  Qed.

(*****************************************************************************************
 *   SORT THE LIST
 *)

  Local Lemma perm_ldenote_M : forall (env:environment)  l l', Permutation.Permutation l l' -> ldenote_M env l = ldenote_M env l'.
  Proof.
    intros env l l' H.
    induction H => // ; simpl.
    by rewrite IHPermutation.
    ring.
    by rewrite IHPermutation1 IHPermutation2.
  Qed.

  Local Lemma sort_ldenote_M : forall (env:environment) l, ldenote_M env l = ldenote_M env (TermSort.sort l).
  Proof.
    intros.
    apply perm_ldenote_M.
    apply TermSort.Permuted_sort.
  Qed.

  Definition flatten_eq l := ListTermSort.sort (map TermSort.sort l).

  Local Lemma perm_ldenote : forall (env:environment)  l l', Permutation.Permutation l l' -> ldenote env l = ldenote env l'.
  Proof.
    intros env  l l' H.
    induction H => // ; simpl.
    by rewrite IHPermutation.
    ring.
    by rewrite IHPermutation1 IHPermutation2.
  Qed.

  Local Lemma sort_ldenote : forall (env:environment)  l, ldenote env l = ldenote env (ListTermSort.sort l).
  Proof.
    intros.
    apply perm_ldenote.
    apply Permuted_sort.
  Qed.

  Theorem flatten_eq_denote : forall (env:environment)  l, ldenote env l = ldenote env (flatten_eq l).
  Proof.
    induction l => //.
    unfold flatten_eq in *.
    rewrite -sort_ldenote.
    simpl.
    f_equal.
    apply sort_ldenote_M.
    by rewrite -sort_ldenote in IHl.
  Qed.

(*****************************************************************************************
 *   DECIDE EQUALITY
 *)

  Fixpoint decide_list_term_eq (l l':list term): bool := match l, l' with
    | nil , nil => true
    | a:: qa , b :: qb => andb (decide a b) (decide_list_term_eq qa qb)
    | _, _ => false
    end.

  Local Lemma decide_list_term_eq_impl:
    forall (env:environment) l l',
    decide_list_term_eq l l' = true ->
    ldenote_M env l = ldenote_M env l'.
  Proof.
  induction l ; destruct l' ; auto => H.
  simpl in H ; discriminate.
  simpl in H ; discriminate.
  simpl in *.
  move: H; rewrite !Bool.andb_true_iff ; move=> [Ht Hl].
  apply IHl in Hl.
  f_equal.
  apply term_decide_impl.
  all: assumption.
  Qed.

  Local Fixpoint decide_list_list_term (l l':list (list term)) : bool := match l, l' with
    | nil, nil => true
    | a:: qa , b :: qb => andb (decide_list_term_eq a b) (decide_list_list_term qa qb)
    | _, _ => false
    end.

  Local Lemma decide_list_list_term_eq_impl : forall (env:environment)  l l', decide_list_list_term l l' = true ->
    ldenote env l = ldenote env l'.
  Proof.
  induction l ; destruct l' ; auto => H.
  simpl in H ; discriminate.
  simpl in H ; discriminate.
  simpl in *.
  move: H; rewrite !Bool.andb_true_iff ; move=> [Ht Hl].
  apply IHl in Hl.
  apply (decide_list_term_eq_impl env) in Ht.
  rewrite Ht Hl ; reflexivity.
  Qed.

Definition decide_llt (l l':list (list term)) : bool := decide_list_list_term (flatten_eq l) (flatten_eq l').

Definition expr_decide (e e': expr) : bool := decide_llt (flatten_expr e) (flatten_expr e').

Lemma expr_decide_impl:
  forall (env:environment) a b,
    expr_decide a b = true ->
    expr_denote env a = expr_denote env b.
Proof.
  intros env a b Hdec.
  unfold expr_decide in Hdec.
  unfold decide_llt in Hdec.
  assert(H: exists l, l = flatten_expr a).
    eexists. reflexivity.
  destruct H as [l Hl].
  assert(Hld: ldenote env l = expr_denote env a).
    rewrite flatten_expr_correct; subst => //.
  assert(H: exists l, l = flatten_expr b).
    eexists. reflexivity.
  destruct H as [l' Hl'].
  assert(Hl'd: ldenote env l' = expr_denote env b).
    rewrite flatten_expr_correct; subst => //.
  rewrite -Hld -Hl'd.
  rewrite flatten_eq_denote ; symmetry ; rewrite flatten_eq_denote ; symmetry ; subst.
  by apply decide_list_list_term_eq_impl.
Qed.

End Expr.

Local Definition ta := Var 1%positive.
Local Definition tb := Var 2%positive.
Local Definition tc := Var 3%positive.
Local Definition td := Var 4%positive.
Local Definition te := Var 5%positive.
Local Definition tf := Var 6%positive.
Local Definition tg := Var 7%positive.

Local Definition expr1 := A (M ta tb) (A (R tc) (R tb)).
Local Definition expr2 := A (A (R tc) (R tb)) (M ta tb).

Local Instance expr_dec : Decidable := Build_Decidable expr Z expr_decide (expr_denote) expr_decide_impl.

Local Example test1 : expr_decide expr1 expr2 = true.
Proof.
by compute.
Qed.

Close Scope Z.


Require Import FunctionalExtensionality Classical ClassicalEpsilon.

Set Implicit Arguments.

Module Map.
  Definition map (A B : Type) := A -> B.

  Definition empty A B (def : B) : map A B := fun _ => def.

  Section decidability.
    Variable P : Prop.

    Lemma decided : inhabited (sum P (~P)).
    Proof.
      destruct (classic P).  (** let us cheat a bit here. *)
      constructor; exact (inl _ H).
      constructor; exact (inr _ H).
    Qed.

    Definition decide : sum P (~P) :=
      epsilon decided (fun _ => True).
  End decidability.

  Definition add A B (m : map A B) (k : A) (v : B) : map A B :=
    fun k' => if decide (k' = k) then v else m k'.

  Definition lookup A B (m : map A B) (k : A) : B := m k.

  Global Infix "$" := lookup (at level 30, no associativity).

  Lemma add_eq : forall A B (m : map A B) (k : A) (v : B),
    lookup (add m k v) k = v.
  Proof.
    unfold add, lookup; intros.
    destruct (decide (k = k)); tauto.
  Qed.

  Theorem add_neq : forall A B (m : map A B) (k1 k2 : A) (v : B),
    k1 <> k2 -> lookup (add m k1 v) k2 = lookup m k2.
  Proof.
    unfold add, lookup; intros.
    destruct (decide (k2 = k1)); subst; try tauto.
  Qed.

  Lemma add_shadow : forall A B (m: map A B) (k : A) (v1 v2 : B),
    add (add m k v1) k v2 = add m k v2.
  Proof.
    unfold add; intros; apply functional_extensionality; intros.
    destruct (decide (x = k)); subst; try tauto.
  Qed.

  Theorem add_permute : forall A B (m : map A B) (k1 k2 : A) (v1 v2 : B),
    k1 <> k2 -> (add (add m k2 v2) k1 v1) = (add (add m k1 v1) k2 v2).
  Proof.
    unfold add; intros; apply functional_extensionality; intros.
    destruct (decide (x = k1)); destruct (decide (x = k2)); subst; tauto.
  Qed.
End Map.

Export Map.


Require Import Coq.Program.Basics.
Require Coq.Logic.FunctionalExtensionality.

Require Import Graph.
Require Import Homomorphism.

Open Scope program_scope.

Fixpoint paragraph {A B : Type} (e:B) (v:A -> B) (o:B -> B -> Graph A -> Graph A -> B) (c:B -> B -> Graph A -> Graph A -> B) (g:Graph A) :=
  match g with
    | Empty => e
    | Vertex x => v x
    | Overlay a b => o (paragraph e v o c a) (paragraph e v o c b) a b
    | Connect a b => c (paragraph e v o c a) (paragraph e v o c b) a b
  end.

Lemma paragraph_overlay : forall A B (e:B) (v:A -> B) (o:B -> B -> Graph A -> Graph A -> B) (c:B -> B -> Graph A -> Graph A ->B) (a:Graph A) (b:Graph A),
  paragraph e v o c (Overlay a b) = o (paragraph e v o c a) (paragraph e v o c b) a b.
Proof. auto. Qed.

Lemma paragraph_connect : forall A B (e:B) (v:A -> B) (o:B -> B -> Graph A -> Graph A -> B) (c:B -> B -> Graph A -> Graph A ->B) (a:Graph A) (b:Graph A),
  paragraph e v o c (Connect a b) = c (paragraph e v o c a) (paragraph e v o c b) a b.
Proof. auto. Qed.

Definition apply2L {A B C D} (f : A -> A -> D -> D -> C) (g:B -> D) := fun a b x y => f a b (g x) (g y).

(* The composition of a paragraph-function and a graph homorphism is a paragraph-function *)
Theorem para_compo {A B C} {e : C} {v: B -> C} {o:C -> C -> Graph B -> Graph B -> C} {c:C -> C -> Graph B -> Graph B -> C} {f : A -> Graph B}:
  paragraph e v o c ∘ bind f = paragraph e (paragraph e v o c ∘ f) (apply2L o (bind f)) (apply2L c (bind f)).
Proof.
  apply FunctionalExtensionality.functional_extensionality.
  intro g.
  unfold compose.
  induction g.
  - auto.
  - auto.
  - pose (H :=bind_is_hom f).
    rewrite Hom_Overlay.
    repeat rewrite paragraph_overlay.
    rewrite IHg1.
    rewrite IHg2.
    reflexivity.
  - pose (H :=bind_is_hom f).
    rewrite Hom_Connect.
    repeat rewrite paragraph_connect.
    rewrite IHg1.
    rewrite IHg2.
    reflexivity.
Qed.


Require Import LL.FOLL.Dyadic.Tactics.
Require Import LL.FOLL.Monadic.StructuralRules.

Section LLAdequacy.
  Context `{OLS: OLSig}.

Theorem LL2N_to_LL1S n B L : LL2N n B L -> LL1S ((map Quest B)++L) .
Proof with sauto.
  intros.
  revert dependent B.
  revert L.
  induction n;intros...
  + inversion H...
      apply LL1weakening with (B:=B) (M:=L)...
      LL1init A.
      apply LL1weakening with (B:=B) (M:=[1])...
      apply LL1weakening with (B:=B) (M:=L)...
      LL1top M.
  + inversion H...
      -
      apply LL1weakening with (B:=B) (M:=L)...
      LL1init A.
      -
      apply LL1weakening with (B:=B) (M:=L)...
      LL1top M.
      -
      LL1plus1 F G  (map Quest B++M).
      rewrite H1...
      rewrite <- Permutation_midle...
      -
      LL1plus2 F G  (map Quest B++M).
      rewrite H1...
      rewrite <- Permutation_midle...
      -
      LL1with F G  (map Quest B++M).
      rewrite H1...
      rewrite <- Permutation_midle...
      rewrite <- Permutation_midle...
      -
      LL1bot   (map Quest B++M).
      rewrite H1...
      -
      LL1par F G  (map Quest B++M).
      rewrite H1...
      rewrite <- Permutation_midle...
      rewrite <- Permutation_midle...
      -
      apply LL1contraction with (B:=B) (M:=L)...
      LL1tensor F G (map Quest B++M) (map Quest B++N).
      rewrite H1...
      rewrite <- Permutation_midle...
      rewrite <- Permutation_midle...
      -
       eapply IHn in H2.
       simpl in H2...
       rewrite H1.
       rewrite  Permutation_midle...
      -
       LL1bang F B...
       rewrite Permutation_cons_append...
       -
       LL1exist t  FX (map Quest B++M).
       rewrite H1...
       rewrite <- Permutation_midle...
       -
       LL1forall  FX (map Quest B++M).
       rewrite H1...
       specialize(H3 x H0).
       rewrite <- Permutation_midle...
       -
       eapply IHn in H2.
       apply InPermutation in H1...
       rewrite H1.
       simpl...
       LL1contr F (map Quest x ++ L).
       LL1store F (? F :: map Quest x ++ L).
       rewrite H1 in H2.
       simpl in H2...
       rewrite perm_swap.
       rewrite <- Permutation_midle...
 Qed.

  (* TODO: generalize this result *)
  Theorem destructMapQuest B C M N:
    Permutation (map Quest B ++ C) (M ++ N) ->
    exists B_1 B_2 C_1 C_2,
    Permutation B ( (B_1 ++ B_2)) /\
    Permutation C (C_1 ++ C_2) /\
    Permutation M (map Quest B_1 ++ C_1) /\
    Permutation N (map Quest B_2 ++ C_2).
  Proof with sauto.
    intros.
    revert dependent C.
    revert dependent M.
    revert dependent N.
    induction B;intros.
    *
      eexists [].
      eexists [].
      eexists M.
      eexists N.
      simpl.
      split;auto.
    *
    simpl in H.
    checkPermutationCases H.
      - symmetry in H1.
         eapply IHB in H1...
           eexists (a::x0).
           eexists x1.
           eexists x2.
           eexists x3.
           split;auto.
           simpl...
           split;auto.
           split;auto.
           simpl...
       - symmetry in H1.
         eapply IHB in H1...
          eexists x0.
        eexists (a::x1).
        eexists x2.
        eexists x3.
        split...
        simpl...
        rewrite H0...
        simpl...
        Qed.

 (* TODO: generalize this result *)
    Theorem destructMapQuest' B C M :
    Permutation (map Quest B ++ C) (map Quest M) ->
    exists C_1,
    Permutation C ( map Quest C_1) /\ Permutation (B++C_1) M  .
  Proof with sauto.
    intros.
    revert dependent B.
    revert dependent C.
    induction M;intros.
    + simpl in H.
        symmetry in H.
        apply Permutation_nil in H...
        exists nil...
        apply map_eq_nil in H...
    +
    simpl in H...
    checkPermutationCases H.
    2:{ apply IHM in H1...
          eexists (a::x0)...
          rewrite H.
          simpl...
          rewrite <- H2...
           }
      symmetry in H.
    apply Permutation_map_inv in H...
    destruct x0...
    simpl in H0.
    inversion H0...
      eapply IHM in H1...
    exists x...
    rewrite H2.
    rewrite <-  H0...
   Qed.

Theorem LL1N_to_LL2S n B L : LL1N n ((map Quest B)++L) -> LL2S B L.
Proof with sauto.
  intros.
  revert dependent B.
  revert L.
  induction n;intros...
  + inversion H...
     - checkPermutationCases H0.
        { destruct B; simpl in H0;
           inversion H0... }
        { destruct B.
           simpl in H0. inversion H0...
           simpl in H0.
          checkPermutationCases H0. }
        LL2init A.
        destruct B;
        simpl in H3; inversion H3...
     - destruct B;
        simpl in H1; inversion H1...
     - assert(In Top L).
           checkPermutationCases H0.
           2:{ rewrite H0... }
        assert(In Top (map Quest B) ).
        rewrite H0...
        apply in_map_iff in H1...
        apply InPermutation in H1...
        LL2top x.
  + inversion H...
     - checkPermutationCases H0.
        { destruct B; simpl in H0;
           inversion H0... }
        { destruct B.
           simpl in H0. inversion H0...
           simpl in H0.
          checkPermutationCases H0. }
        LL2init A.
        destruct B;
        simpl in H3; inversion H3...
     - destruct B;
        simpl in H1; inversion H1...
     - assert(In Top L).
           checkPermutationCases H0.
           2:{ rewrite H0... }
        assert(In Top (map Quest B) ).
        rewrite H0...
        apply in_map_iff in H1...
        apply InPermutation in H1...
        LL2top x.
       - assert(~ In (F ⊕ G)  (map Quest B) ).
        intro.
        apply in_map_iff in H0...
        assert(In (F ⊕ G) L ).
           checkPermutationCases H1.
           2:{ rewrite H1... }
        assert(In (F ⊕ G)  (map Quest B) ).
        rewrite H1...
        contradiction.
        checkPermutationCases H1.
        rewrite H1 in H0.
        elim H0...
        LL2plus1 F G x.
        eapply IHn.
        rewrite Permutation_midle.
        rewrite H5...
       - assert(~ In (F ⊕ G)  (map Quest B) ).
        intro.
        apply in_map_iff in H0...
        assert(In (F ⊕ G) L ).
           checkPermutationCases H1.
           2:{ rewrite H1... }
        assert(In (F ⊕ G)  (map Quest B) ).
        rewrite H1...
        contradiction.
        checkPermutationCases H1.
        rewrite H1 in H0.
        elim H0...
        LL2plus2 F G x.
        eapply IHn.
        rewrite Permutation_midle.
        rewrite H5...
       - assert(~ In (F & G)  (map Quest B) ).
        intro.
        apply in_map_iff in H0...
        assert(In (F & G) L ).
           checkPermutationCases H1.
           2:{ rewrite H1... }
        assert(In (F & G)  (map Quest B) ).
        rewrite H1...
        contradiction.
        checkPermutationCases H1.
        rewrite H1 in H0.
        elim H0...
        LL2with F G x.
        eapply IHn.
        rewrite !Permutation_midle.
        rewrite H6...
        eapply IHn.
        rewrite !Permutation_midle.
        rewrite H6...
   - assert(~ In Bot  (map Quest B) ).
        intro.
        apply in_map_iff in H0...
        assert(In Bot L ).
           checkPermutationCases H1.
           2:{ rewrite H1... }
        assert(In Bot  (map Quest B) ).
        rewrite H1...
        contradiction.
        checkPermutationCases H1.
        rewrite H1 in H0.
        elim H0...
        LL2bot  x.
        eapply IHn.
        rewrite H5...
       - assert(~ In (F ⅋ G)  (map Quest B) ).
        intro.
        apply in_map_iff in H0...
        assert(In (F ⅋ G) L ).
           checkPermutationCases H1.
           2:{ rewrite H1... }
        assert(In (F ⅋ G)  (map Quest B) ).
        rewrite H1...
        contradiction.
        checkPermutationCases H1.
        rewrite H1 in H0.
        elim H0...
        LL2par F G x.
        eapply IHn.
        rewrite !Permutation_midle.
        rewrite H5...
        - assert(~ In (F ⊗ G)  (map Quest B) ).
        intro.
        apply in_map_iff in H0...
        assert(In (F ⊗ G) L ).
           checkPermutationCases H1.
           2:{ rewrite H1... }
        assert(In (F ⊗ G)  (map Quest B) ).
        rewrite H1...
        contradiction.
        checkPermutationCases H1.
        rewrite H1 in H0.
        elim H0...
        apply destructMapQuest in H6...
        LL2tensor F G x2 x3.
        rewrite H7 in H2.
        rewrite <- Permutation_midle in H2.
        eapply IHn in H2.
        rewrite H5.
        rewrite Permutation_app_comm.
        apply LL2weakeningGen...
        rewrite H10 in H3.
        rewrite <- Permutation_midle in H3.
        eapply IHn in H3.
        rewrite H5.
        apply LL2weakeningGen...
   -
       checkPermutationCases H1.
       assert(In F B).
       assert(In (? F)  (map Quest B) ).
       rewrite H1...
       apply in_map_iff in H0...
       inversion H4...
       LL2copy F.
       apply InPermutation in H0...
       rewrite H0.
       apply LL2weakening.
       eapply IHn.
       rewrite H0 in H1.
       simpl in H1.
       apply Permutation_cons_inv in H1.
       rewrite H1...
       rewrite !Permutation_midle.
        rewrite H3...
      rewrite <- H3 in H2.
      rewrite <- !Permutation_midle in H2.
        eapply IHn
        in H2.
        LL2store F x.
        LL2copy F...
        apply LL2weakening...
   - assert(~ In (! F )  (map Quest B) ).
        intro.
        apply in_map_iff in H0...
        assert(In (! F) L ).
           checkPermutationCases H1.
           2:{ rewrite H1... }
        assert(In (! F)  (map Quest B) ).
        rewrite H1...
        contradiction.
        checkPermutationCases H1.
        rewrite H1 in H0.
        elim H0...
        apply destructMapQuest' in H5...
        rewrite Permutation_cons_append in H2.
        eapply IHn in H2.
        rewrite H4 in H1.
        rewrite H1.
        rewrite Permutation_cons_append.
        apply LL2storeGen.
        LL2bang.
        rewrite Permutation_app_comm.
        rewrite H6...
        - assert(~ In (∃{ FX})  (map Quest B) ).
        intro.
        apply in_map_iff in H0...
        assert(In (∃{ FX}) L ).
           checkPermutationCases H1.
           2:{ rewrite H1... }
        assert(In (∃{ FX})  (map Quest B) ).
        rewrite H1...
        contradiction.
        checkPermutationCases H1.
        rewrite H1 in H0.
        elim H0...
        LL2exist t FX x.
        eapply IHn.
        rewrite !Permutation_midle.
        rewrite H7...
        - assert(~ In (∀{ FX})  (map Quest B) ).
        intro.
        apply in_map_iff in H0...
        assert(In (∀{ FX}) L ).
           checkPermutationCases H1.
           2:{ rewrite H1... }
        assert(In (∀{ FX})  (map Quest B) ).
        rewrite H1...
        contradiction.
        checkPermutationCases H1.
        rewrite H1 in H0.
        elim H0...
        LL2forall FX x.
        specialize (H3 x0 H5).
        eapply IHn.
        rewrite !Permutation_midle.
        rewrite H6...
        - checkPermutationCases H1.
          symmetry in H1.
    apply Permutation_map_inv in H1...
    destruct x0...
    simpl in H0.
    inversion H0...

    rewrite <- H3 in H2.
    apply IHn in H2.
    rewrite H4.
    apply LL2weakening...
    rewrite <- H3 in H2.
    apply IHn in H2.
    LL2store F x.
    apply LL2weakening...
        - checkPermutationCases H1.
          symmetry in H1.
    apply Permutation_map_inv in H1...
    destruct x0...
    simpl in H0.
    inversion H0...
    rewrite app_comm_cons in H2.
    rewrite <- map_cons in H2.
    apply IHn in H2.
    rewrite H4.
    apply LL2contraction with (F:=o)...
    rewrite <- H4.
    rewrite Permutation_app_comm...
    rewrite H1 in H2.
    rewrite PermutConsApp in H2.
    rewrite !app_comm_cons in H2.
    rewrite <- !map_cons in H2.
    apply IHn in H2.
    LL2store F x.
    apply LL2contraction with (F:=F)...
    rewrite Permutation_app_comm...
    Qed.

End LLAdequacy.