Require Import NZAxioms NZMulOrder.

Module Type DivMod (Import A : Typ).
Parameters Inline div modulo : t -> t -> t.
End DivMod.

Module Type DivModNotation (A : Typ)(Import B : DivMod A).
Infix "/" := div.
Infix "mod" := modulo (at level 40, no associativity).
End DivModNotation.

Module Type DivMod' (A : Typ) := DivMod A <+ DivModNotation A.

Module Type NZDivSpec (Import A : NZOrdAxiomsSig')(Import B : DivMod' A).
Declare Instance div_wd : Proper (eq==>eq==>eq) div.
Declare Instance mod_wd : Proper (eq==>eq==>eq) modulo.
Axiom div_mod : forall a b, b ~= 0 -> a == b*(a/b) + (a mod b).
Axiom mod_bound_pos : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
End NZDivSpec.

Module Type NZDiv (A : NZOrdAxiomsSig) := DivMod A <+ NZDivSpec A.
Module Type NZDiv' (A : NZOrdAxiomsSig) := NZDiv A <+ DivModNotation A.

From Hammer Require Import Hammer.

Module Type NZDivProp
(Import A : NZOrdAxiomsSig')
(Import B : NZDiv' A)
(Import C : NZMulOrderProp A).

Theorem div_mod_unique :
forall b q1 q2 r1 r2, 0<=r1<b -> 0<=r2<b ->
b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_mod_unique".
intros b.
assert (U : forall q1 q2 r1 r2,
b*q1+r1 == b*q2+r2 -> 0<=r1<b -> 0<=r2 -> q1<q2 -> False).
intros q1 q2 r1 r2 EQ LT Hr1 Hr2.
contradict EQ.
apply lt_neq.
apply lt_le_trans with (b*q1+b).
rewrite <- add_lt_mono_l. tauto.
apply le_trans with (b*q2).
rewrite mul_comm, <- mul_succ_l, mul_comm.
apply mul_le_mono_nonneg_l; intuition; try order.
rewrite le_succ_l; auto.
rewrite <- (add_0_r (b*q2)) at 1.
rewrite <- add_le_mono_l. tauto.

intros q1 q2 r1 r2 Hr1 Hr2 EQ; destruct (lt_trichotomy q1 q2) as [LT|[EQ'|GT]].
elim (U q1 q2 r1 r2); intuition.
split; auto. rewrite EQ' in EQ. rewrite add_cancel_l in EQ; auto.
elim (U q2 q1 r2 r1); intuition.
Qed.

Theorem div_unique:
forall a b q r, 0<=a -> 0<=r<b ->
a == b*q + r -> q == a/b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_unique".
intros a b q r Ha (Hb,Hr) EQ.
destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
apply mod_bound_pos; order.
rewrite <- div_mod; order.
Qed.

Theorem mod_unique:
forall a b q r, 0<=a -> 0<=r<b ->
a == b*q + r -> r == a mod b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_unique".
intros a b q r Ha (Hb,Hr) EQ.
destruct (div_mod_unique b q (a/b) r (a mod b)); auto.
apply mod_bound_pos; order.
rewrite <- div_mod; order.
Qed.

Theorem div_unique_exact a b q:
0<=a -> 0<b -> a == b*q -> q == a/b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_unique_exact".
intros Ha Hb H. apply div_unique with 0; nzsimpl; now try split.
Qed.

Lemma div_same : forall a, 0<a -> a/a == 1.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_same".
intros. symmetry. apply div_unique_exact; nzsimpl; order.
Qed.

Lemma mod_same : forall a, 0<a -> a mod a == 0.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_same".
intros. symmetry.
apply mod_unique with 1; intuition; try order.
now nzsimpl.
Qed.

Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_small".
intros. symmetry.
apply div_unique with a; intuition; try order.
now nzsimpl.
Qed.

Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_small".
intros. symmetry.
apply mod_unique with 0; intuition; try order.
now nzsimpl.
Qed.

Lemma div_0_l: forall a, 0<a -> 0/a == 0.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_0_l".
intros; apply div_small; split; order.
Qed.

Lemma mod_0_l: forall a, 0<a -> 0 mod a == 0.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_0_l".
intros; apply mod_small; split; order.
Qed.

Lemma div_1_r: forall a, 0<=a -> a/1 == a.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_1_r".
intros. symmetry. apply div_unique_exact; nzsimpl; order'.
Qed.

Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_1_r".
intros. symmetry.
apply mod_unique with a; try split; try order; try apply lt_0_1.
now nzsimpl.
Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_1_l".
intros; apply div_small; split; auto. apply le_0_1.
Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_1_l".
intros; apply mod_small; split; auto. apply le_0_1.
Qed.

Lemma div_mul : forall a b, 0<=a -> 0<b -> (a*b)/b == a.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_mul".
intros; symmetry. apply div_unique_exact; trivial.
apply mul_nonneg_nonneg; order.
apply mul_comm.
Qed.

Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_mul".
intros; symmetry.
apply mod_unique with a; try split; try order.
apply mul_nonneg_nonneg; order.
nzsimpl; apply mul_comm.
Qed.

Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_le".
intros. destruct (le_gt_cases b a).
apply le_trans with b; auto.
apply lt_le_incl. destruct (mod_bound_pos a b); auto.
rewrite lt_eq_cases; right.
apply mod_small; auto.
Qed.

Lemma div_pos: forall a b, 0<=a -> 0<b -> 0 <= a/b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_pos".
intros.
rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl.
rewrite (add_le_mono_r _ _ (a mod b)).
rewrite <- div_mod by order.
nzsimpl.
apply mod_le; auto.
Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_str_pos".
intros a b (Hb,Hab).
assert (LE : 0 <= a/b) by (apply div_pos; order).
assert (MOD : a mod b < b) by (destruct (mod_bound_pos a b); order).
rewrite lt_eq_cases in LE; destruct LE as [LT|EQ]; auto.
exfalso; revert Hab.
rewrite (div_mod a b), <-EQ; nzsimpl; order.
Qed.

Lemma div_small_iff : forall a b, 0<=a -> 0<b -> (a/b==0 <-> a<b).
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_small_iff".
intros a b Ha Hb; split; intros Hab.
destruct (lt_ge_cases a b); auto.
symmetry in Hab. contradict Hab. apply lt_neq, div_str_pos; auto.
apply div_small; auto.
Qed.

Lemma mod_small_iff : forall a b, 0<=a -> 0<b -> (a mod b == a <-> a<b).
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_small_iff".
intros a b Ha Hb. split; intros H; auto using mod_small.
rewrite <- div_small_iff; auto.
rewrite <- (mul_cancel_l _ _ b) by order.
rewrite <- (add_cancel_r _ _ (a mod b)).
rewrite <- div_mod, H by order. now nzsimpl.
Qed.

Lemma div_str_pos_iff : forall a b, 0<=a -> 0<b -> (0<a/b <-> b<=a).
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_str_pos_iff".
intros a b Ha Hb; split; intros Hab.
destruct (lt_ge_cases a b) as [LT|LE]; auto.
rewrite <- div_small_iff in LT; order.
apply div_str_pos; auto.
Qed.

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_lt".
intros.
assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1).
destruct (lt_ge_cases a b).
rewrite div_small; try split; order.
rewrite (div_mod a b) at 2 by order.
apply lt_le_trans with (b*(a/b)).
rewrite <- (mul_1_l (a/b)) at 1.
rewrite <- mul_lt_mono_pos_r; auto.
apply div_str_pos; auto.
rewrite <- (add_0_r (b*(a/b))) at 1.
rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order.
Qed.

Lemma div_le_mono : forall a b c, 0<c -> 0<=a<=b -> a/c <= b/c.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_le_mono".
intros a b c Hc (Ha,Hab).
rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
[|rewrite EQ; order].
rewrite <- lt_succ_r.
rewrite (mul_lt_mono_pos_l c) by order.
nzsimpl.
rewrite (add_lt_mono_r _ _ (a mod c)).
rewrite <- div_mod by order.
apply lt_le_trans with b; auto.
rewrite (div_mod b c) at 1 by order.
rewrite <- add_assoc, <- add_le_mono_l.
apply le_trans with (c+0).
nzsimpl; destruct (mod_bound_pos b c); order.
rewrite <- add_le_mono_l. destruct (mod_bound_pos a c); order.
Qed.

Lemma mul_div_le : forall a b, 0<=a -> 0<b -> b*(a/b) <= a.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mul_div_le".
intros.
rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order.
rewrite <- (add_0_r a) at 1.
rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order.
Qed.

Lemma mul_succ_div_gt : forall a b, 0<=a -> 0<b -> a < b*(S (a/b)).
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mul_succ_div_gt".
intros.
rewrite (div_mod a b) at 1 by order.
rewrite (mul_succ_r).
rewrite <- add_lt_mono_l.
destruct (mod_bound_pos a b); auto.
Qed.

Lemma div_exact : forall a b, 0<=a -> 0<b -> (a == b*(a/b) <-> a mod b == 0).
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_exact".
intros. rewrite (div_mod a b) at 1 by order.
rewrite <- (add_0_r (b*(a/b))) at 2.
apply add_cancel_l.
Qed.

Theorem div_lt_upper_bound:
forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_lt_upper_bound".
intros.
rewrite (mul_lt_mono_pos_l b) by order.
apply le_lt_trans with a; auto.
apply mul_div_le; auto.
Qed.

Theorem div_le_upper_bound:
forall a b q, 0<=a -> 0<b -> a <= b*q -> a/b <= q.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_le_upper_bound".
intros.
rewrite (mul_le_mono_pos_l _ _ b) by order.
apply le_trans with a; auto.
apply mul_div_le; auto.
Qed.

Theorem div_le_lower_bound:
forall a b q, 0<=a -> 0<b -> b*q <= a -> q <= a/b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_le_lower_bound".
intros a b q Ha Hb H.
destruct (lt_ge_cases 0 q).
rewrite <- (div_mul q b); try order.
apply div_le_mono; auto.
rewrite mul_comm; split; auto.
apply lt_le_incl, mul_pos_pos; auto.
apply le_trans with 0; auto; apply div_pos; auto.
Qed.

Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r ->
p/r <= p/q.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_le_compat_l".
intros p q r Hp (Hq,Hqr).
apply div_le_lower_bound; auto.
rewrite (div_mod p r) at 2 by order.
apply le_trans with (r*(p/r)).
apply mul_le_mono_nonneg_r; try order.
apply div_pos; order.
rewrite <- (add_0_r (r*(p/r))) at 1.
rewrite <- add_le_mono_l. destruct (mod_bound_pos p r); order.
Qed.

Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
(a + b * c) mod c == a mod c.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_add".
intros.
symmetry.
apply mod_unique with (a/c+b); auto.
apply mod_bound_pos; auto.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c ->
(a + b * c) / c == a / c + b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_add".
intros.
apply (mul_cancel_l _ _ c); try order.
apply (add_cancel_r _ _ ((a+b*c) mod c)).
rewrite <- div_mod, mod_add by order.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add_l: forall a b c, 0<=c -> 0<=a*b+c -> 0<b ->
(a * b + c) / b == a + c / b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_add_l".
intros a b c. rewrite (add_comm _ c), (add_comm a).
intros. apply div_add; auto.
Qed.

Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0<b -> 0<c ->
(a*c)/(b*c) == a/b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_mul_cancel_r".
intros.
symmetry.
apply div_unique with ((a mod b)*c).
apply mul_nonneg_nonneg; order.
split.
apply mul_nonneg_nonneg; destruct (mod_bound_pos a b); order.
rewrite <- mul_lt_mono_pos_r; auto. destruct (mod_bound_pos a b); auto.
rewrite (div_mod a b) at 1 by order.
rewrite mul_add_distr_r.
rewrite add_cancel_r.
rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
Qed.

Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0<b -> 0<c ->
(c*a)/(c*b) == a/b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_mul_cancel_l".
intros. rewrite !(mul_comm c); apply div_mul_cancel_r; auto.
Qed.

Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0<b -> 0<c ->
(c*a) mod (c*b) == c * (a mod b).
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mul_mod_distr_l".
intros.
rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
rewrite <- div_mod.
rewrite div_mul_cancel_l; auto.
rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
apply div_mod; order.
rewrite <- neq_mul_0; intuition; order.
Qed.

Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0<b -> 0<c ->
(a*c) mod (b*c) == (a mod b) * c.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mul_mod_distr_r".
intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
Qed.

Theorem mod_mod: forall a n, 0<=a -> 0<n ->
(a mod n) mod n == a mod n.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_mod".
intros. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff.
Qed.

Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
((a mod n)*b) mod n == (a*b) mod n.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mul_mod_idemp_l".
intros a b n Ha Hb Hn. symmetry.
generalize (mul_nonneg_nonneg _ _ Ha Hb).
rewrite (div_mod a n) at 1 2 by order.
rewrite add_comm, (mul_comm n), (mul_comm _ b).
rewrite mul_add_distr_l, mul_assoc.
intros. rewrite mod_add; auto.
now rewrite mul_comm.
apply mul_nonneg_nonneg; destruct (mod_bound_pos a n); auto.
Qed.

Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
(a*(b mod n)) mod n == (a*b) mod n.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mul_mod_idemp_r".
intros. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto.
Qed.

Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
(a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mul_mod".
intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. reflexivity.
now destruct (mod_bound_pos b n).
Qed.

Lemma add_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n ->
((a mod n)+b) mod n == (a+b) mod n.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.add_mod_idemp_l".
intros a b n Ha Hb Hn. symmetry.
generalize (add_nonneg_nonneg _ _ Ha Hb).
rewrite (div_mod a n) at 1 2 by order.
rewrite <- add_assoc, add_comm, mul_comm.
intros. rewrite mod_add; trivial. reflexivity.
apply add_nonneg_nonneg; auto. destruct (mod_bound_pos a n); auto.
Qed.

Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n ->
(a+(b mod n)) mod n == (a+b) mod n.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.add_mod_idemp_r".
intros. rewrite !(add_comm a). apply add_mod_idemp_l; auto.
Qed.

Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n ->
(a+b) mod n == (a mod n + b mod n) mod n.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.add_mod".
intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. reflexivity.
now destruct (mod_bound_pos b n).
Qed.

Lemma div_div : forall a b c, 0<=a -> 0<b -> 0<c ->
(a/b)/c == a/(b*c).
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_div".
intros a b c Ha Hb Hc.
apply div_unique with (b*((a/b) mod c) + a mod b); trivial.

destruct (mod_bound_pos (a/b) c), (mod_bound_pos a b); auto using div_pos.
split.
apply add_nonneg_nonneg; auto.
apply mul_nonneg_nonneg; order.
apply lt_le_trans with (b*((a/b) mod c) + b).
rewrite <- add_lt_mono_l; auto.
rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l; auto.

rewrite (div_mod a b) at 1 by order.
rewrite add_assoc, add_cancel_r.
rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
apply div_mod; order.
Qed.

Lemma mod_mul_r : forall a b c, 0<=a -> 0<b -> 0<c ->
a mod (b*c) == a mod b + b*((a/b) mod c).
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_mul_r".
intros a b c Ha Hb Hc.
apply add_cancel_l with (b*c*(a/(b*c))).
rewrite <- div_mod by (apply neq_mul_0; split; order).
rewrite <- div_div by trivial.
rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
rewrite <- div_mod by order.
apply div_mod; order.
Qed.

Theorem div_mul_le:
forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.div_mul_le".
intros.
apply div_le_lower_bound; auto.
apply mul_nonneg_nonneg; auto.
rewrite mul_assoc, (mul_comm b c), <- mul_assoc.
apply mul_le_mono_nonneg_l; auto.
apply mul_div_le; auto.
Qed.

Lemma mod_divides : forall a b, 0<=a -> 0<b ->
(a mod b == 0 <-> exists c, a == b*c).
Proof. hammer_hook "NZDiv" "NZDiv.NZDivProp.mod_divides".
split.
intros. exists (a/b). rewrite div_exact; auto.
intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto.
rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order.
Qed.

End NZDivProp.


(* llpol example file for yalla library *)

(* output in Type *)

(** * Example of a concrete use of the yalla library: polarized linear logic LLpol *)

Require Import CMorphisms.

Require Import Injective.
Require Import List_more.
Require Import List_Type_more.
Require Import Permutation_Type.
Require Import Permutation_Type_more.
Require Import Permutation_Type_solve.

(** ** 0. load the [ll] library *)

Require ll_cut.

(** ** 1. define formulas *)

(** Positive and negative formulas *)
Inductive pformula : Set :=
| var : formulas.Atom -> pformula
| one : pformula
| tens : pformula -> pformula -> pformula
| zero : pformula
| aplus : pformula -> pformula -> pformula
| oc : nformula -> pformula
with nformula : Set :=
| covar : formulas.Atom -> nformula
| bot : nformula
| parr : nformula -> nformula -> nformula
| top : nformula
| awith : nformula -> nformula -> nformula
| wn : pformula -> nformula.

Scheme pform_ind := Induction for pformula Sort Prop
  with nform_ind := Induction for nformula Sort Prop.
Combined Scheme polform_ind from pform_ind, nform_ind.

Inductive formula : Set :=
| pos : pformula -> formula
| neg : nformula -> formula.

Fixpoint pdual P :=
match P with
| var x     => covar x
| one       => bot
| tens P Q  => parr (pdual Q) (pdual P)
| zero      => top
| aplus P Q => awith (pdual P) (pdual Q)
| oc N      => wn (ndual N)
end
with ndual N :=
match N with
| covar x   => var x
| bot       => one
| parr N M  => tens (ndual M) (ndual N)
| top       => zero
| awith N M => aplus (ndual N) (ndual M)
| wn P      => oc (pdual P)
end.

Lemma bipndual :
     (forall P, ndual (pdual P) = P)
  /\ (forall N, pdual (ndual N) = N).
Proof.
apply polform_ind ; intros ; simpl ;
  try rewrite H ; try rewrite H0 ; try reflexivity.
Qed.

Definition dual A :=
match A with
| pos P => neg (pdual P)
| neg N => pos (ndual N)
end.

(** ** 2. define embedding into [formulas.formula] *)

Fixpoint pllpol2ll P :=
match P with
| var x => formulas.var x
| one => formulas.one
| tens P Q => formulas.tens (pllpol2ll P) (pllpol2ll Q)
| zero => formulas.zero
| aplus P Q => formulas.aplus (pllpol2ll P) (pllpol2ll Q)
| oc N => formulas.oc (nllpol2ll N)
end
with nllpol2ll N :=
match N with
| covar x => formulas.covar x
| bot => formulas.bot
| parr N M => formulas.parr (nllpol2ll N) (nllpol2ll M)
| top => formulas.top
| awith N M => formulas.awith (nllpol2ll N) (nllpol2ll M)
| wn P => formulas.wn (pllpol2ll P)
end.

Definition llpol2ll A :=
match A with
| pos P => pllpol2ll P
| neg N => nllpol2ll N
end.

Lemma billpol2ll_inj : injective pllpol2ll /\ injective nllpol2ll.
Proof with try reflexivity.
apply polform_ind ;
  try (intros P Heq ; destruct P ; inversion Heq ; reflexivity) ;
  try (intros A IH1 B IH2 C Heq ; destruct C ; inversion Heq ;
       apply IH1 in H0 ; apply IH2 in H1 ; subst ; reflexivity).
- intros x P Heq ; destruct P ; inversion Heq...
- intros N IH M Heq ; destruct M ; inversion Heq.
  apply IH in H0 ; subst...
- intros x N Heq ; destruct N ; inversion Heq...
- intros P IH Q Heq ; destruct Q ; inversion Heq.
  apply IH in H0 ; subst...
Qed.

Lemma llpol2ll_inj : injective llpol2ll.
Proof with try assumption.
intros A B Heq.
destruct A ; destruct B.
- simpl in Heq.
  f_equal.
  apply billpol2ll_inj...
- destruct p ; destruct n ; inversion Heq.
- destruct p ; destruct n ; inversion Heq.
- simpl in Heq.
  f_equal.
  apply billpol2ll_inj...
Qed.

Lemma billpol2ll_dual :
     (forall P, formulas.dual (pllpol2ll P) = nllpol2ll (pdual P))
  /\ (forall N, formulas.dual (nllpol2ll N) = pllpol2ll (ndual N)).
Proof.
apply polform_ind ; intros ; simpl ;
  try rewrite H ; try rewrite H0 ; reflexivity.
Qed.

Lemma llpol2ll_dual : forall A, formulas.dual (llpol2ll A) = llpol2ll (dual A).
Proof.
destruct A ; apply billpol2ll_dual.
Qed.

Lemma bidual : forall A, dual (dual A) = A.
Proof.
intros A.
apply llpol2ll_inj.
rewrite <- 2 llpol2ll_dual.
rewrite formulas.bidual.
reflexivity.
Qed.

Lemma llpol2ll_map_wn : forall l,
    map llpol2ll (map neg (map wn l))
  = map formulas.wn (map pllpol2ll l).
Proof with try reflexivity.
induction l...
simpl ; rewrite IHl...
Qed.

Lemma llpol2ll_map_wn_inv : forall l1 l2,
  map formulas.wn l1 = map llpol2ll l2 ->
    { l2' : _ & l2 = map neg (map wn l2') & l1 = map pllpol2ll l2' }.
Proof with try assumption ; try reflexivity.
induction l1 ; intros l2 Heq ;
  destruct l2 ; inversion Heq...
- exists nil ; split...
- apply IHl1 in H1.
  destruct f ; inversion H0 ;
    [ destruct p | destruct n ] ; inversion H0 ; subst.
  destruct H1 as [l2' Heq1 H1] ; subst.
  exists (p :: l2') ; split...
Qed.

(** ** 3. define proofs *)

(** [ll] restricted to polarized formulas *)
Inductive llpol : list formula -> Type :=
| ax_r : forall X, llpol (neg (covar X) :: pos (var X) :: nil)
| ex_r : forall l1 l2, llpol l1 ->
              Permutation_Type l1 l2 -> llpol l2
| one_r : llpol (pos one :: nil)
| bot_r : forall l, llpol l -> llpol (neg bot :: l)
| tens_r : forall P Q l1 l2,
              llpol (pos P :: l1) -> llpol (pos Q :: l2) ->
              llpol (pos (tens P Q) :: l1 ++ l2)
| parr_r : forall N M l,
              llpol (neg N :: neg M :: l) ->
              llpol (neg (parr N M) :: l)
| top_r : forall l, llpol (neg top :: l)
| plus_r1 : forall P Q l,
              llpol (pos P :: l) -> llpol (pos (aplus P Q) :: l)
| plus_r2 : forall P Q l,
              llpol (pos P :: l) -> llpol (pos (aplus Q P) :: l)
| with_r : forall N M l,
              llpol (neg N :: l) -> llpol (neg M :: l) ->
              llpol (neg (awith N M) :: l)
| oc_r : forall N l,
              llpol (neg N :: map neg (map wn l)) ->
              llpol (pos (oc N) :: map neg (map wn l))
| de_r : forall P l,
              llpol (pos P :: l) -> llpol (neg (wn P) :: l)
| wk_r : forall P l,
              llpol l -> llpol (neg (wn P) :: l)
| co_r : forall P l,
              llpol (neg (wn P) :: neg (wn P) :: l) ->
              llpol (neg (wn P) :: l).

Instance llpol_perm : Proper ((@Permutation_Type _) ==> Basics.arrow) llpol.
Proof.
intros l1 l2 HP pi.
eapply ex_r ; eassumption.
Qed.

(** ** 4. characterize corresponding [ll] fragment *)

(*
Lemma llpol2ll_dec : forall A,
  {B | A = llpol2ll B} + (forall B, A = llpol2ll B -> False).
Proof with try reflexivity.
induction A.
- left ; exists (pos (var a))...
- left ; exists (neg (covar a))...
- left ; exists (pos one)...
- left ; exists (neg bot)...
- destruct IHA1 as [[[p1 | n1] Heq1] | pi1] ;
  destruct IHA2 as [[[p2 | n2] Heq2] | pi2] ; subst ;
    try now
      (right ; intros B Heq ;
       destruct B ; try destruct p ; try destruct n ; inversion Heq ;
       (try now (destruct n1 ; destruct p1 ; inversion H0)) ;
       (try now (destruct n2 ; destruct p2 ; inversion H1)) ;
       (try now (destruct n2 ; destruct p3 ; inversion H1))).
  + left ; exists (pos (tens p1 p2))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi2 (pos p3))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi1 (pos p1))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi2 (pos p2))...
- destruct IHA1 as [[[p1 | n1] Heq1] | pi1] ;
  destruct IHA2 as [[[p2 | n2] Heq2] | pi2] ; subst ;
    try now
      (right ; intros B Heq ;
       destruct B ; try destruct p ; try destruct n ; inversion Heq ;
       (try now (destruct n1 ; destruct p1 ; inversion H0)) ;
       (try now (destruct n2 ; destruct p2 ; inversion H1)) ;
       (try now (destruct p2 ; destruct n3 ; inversion H1))).
  + left ; exists (neg (parr n1 n2))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi2 (neg n3))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi1 (neg n1))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi2 (neg n2))...
- left ; exists (pos zero)...
- left ; exists (neg top)...
- destruct IHA1 as [[[p1 | n1] Heq1] | pi1] ;
  destruct IHA2 as [[[p2 | n2] Heq2] | pi2] ; subst ;
    try now
      (right ; intros B Heq ;
       destruct B ; try destruct p ; try destruct n ; inversion Heq ;
       (try now (destruct n1 ; destruct p1 ; inversion H0)) ;
       (try now (destruct n2 ; destruct p2 ; inversion H1)) ;
       (try now (destruct n2 ; destruct p3 ; inversion H1))).
  + left ; exists (pos (aplus p1 p2))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi2 (pos p3))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi1 (pos p1))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi2 (pos p2))...
- destruct IHA1 as [[[p1 | n1] Heq1] | pi1] ;
  destruct IHA2 as [[[p2 | n2] Heq2] | pi2] ; subst ;
    try now
      (right ; intros B Heq ;
       destruct B ; try destruct p ; try destruct n ; inversion Heq ;
       (try now (destruct n1 ; destruct p1 ; inversion H0)) ;
       (try now (destruct n2 ; destruct p2 ; inversion H1)) ;
       (try now (destruct p2 ; destruct n3 ; inversion H1))).
  + left ; exists (neg (awith n1 n2))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi2 (neg n3))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi1 (neg n1))...
  + right ; intros B Heq.
    destruct B ; try destruct n ; try destruct p ; inversion Heq ; subst.
    apply (pi2 (neg n2))...
- destruct IHA as [[[p | n] Heq] | pi] ; subst.
  + right ; intros B Heq.
    destruct B ; try destruct p0 ; try destruct n ;
      destruct p ; inversion Heq.
  + left ; exists (pos (oc n))...
  + right ; intros B Heq.
    destruct B ; try destruct p ; inversion Heq ; subst...
    * apply (pi (neg n))...
    * destruct n ; inversion H0.
- destruct IHA as [[[p | n] Heq] | pi] ; subst.
  + left ; exists (neg (wn p))...
  + right ; intros B Heq.
    destruct B ; try destruct n0 ; try destruct p ;
      destruct n ; inversion Heq.
  + right ; intros B Heq.
    destruct B ; try destruct n ; inversion Heq ; subst...
    * destruct p ; inversion H0.
    * apply (pi (pos p))...
Qed.

Definition llpol_fragment A :=
match (llpol2ll_dec A) with
| inl _ => true
| inr _ => false
end.

Lemma llpol_is_fragment : ll_prop.fragment llpol_fragment.
Proof with try reflexivity.
intros A HfA B Hsf.
induction Hsf ;
unfold llpol_fragment in HfA ;
(destruct (llpol2ll_dec A) ;
  [ destruct s as [A' Heq] ; subst ;
    unfold llpol_fragment ;
    destruct (llpol2ll_dec (llpol2ll A')) ;
    [ | exfalso ; eapply f ]
  | ])...
- inversion HfA.
- destruct (llpol2ll_dec (formulas.tens B C)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (pllpol2ll p1)) ;
    [ | exfalso ; apply (f0 (pos p1)) ]...
- destruct (llpol2ll_dec (formulas.tens C B)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (pllpol2ll p2)) ;
    [ | exfalso ; apply (f0 (pos p2)) ]...
- destruct (llpol2ll_dec (formulas.parr B C)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (nllpol2ll n1)) ;
    [ | exfalso ; apply (f0 (neg n1)) ]...
- destruct (llpol2ll_dec (formulas.parr C B)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (nllpol2ll n2)) ;
    [ | exfalso ; apply (f0 (neg n2)) ]...
- destruct (llpol2ll_dec (formulas.aplus B C)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (pllpol2ll p1)) ;
    [ | exfalso ; apply (f0 (pos p1)) ]...
- destruct (llpol2ll_dec (formulas.aplus C B)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (pllpol2ll p2)) ;
    [ | exfalso ; apply (f0 (pos p2)) ]...
- destruct (llpol2ll_dec (formulas.awith B C)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (nllpol2ll n1)) ;
    [ | exfalso ; apply (f0 (neg n1)) ]...
- destruct (llpol2ll_dec (formulas.awith C B)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (nllpol2ll n2)) ;
    [ | exfalso ; apply (f0 (neg n2)) ]...
- destruct (llpol2ll_dec (formulas.oc B)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (nllpol2ll n)) ;
    [ | exfalso ; apply (f0 (neg n)) ]...
- destruct (llpol2ll_dec (formulas.wn B)) ; try now inversion HfA.
  destruct s as [B' Heq].
  destruct B' ; [ destruct p | destruct n ] ; inversion Heq ; subst.
  apply IHHsf.
  unfold llpol_fragment ; destruct (llpol2ll_dec (pllpol2ll p)) ;
    [ | exfalso ; apply (f0 (pos p)) ]...
Qed.
*)

(** cut / axioms / mix0 / mix2 / permutation *)
Definition pfrag_mell := ll_def.mk_pfrag false ll_def.NoAxioms false false true.
(*                                       cut   axioms          mix0  mix2  perm  *)

(** ** 5. prove equivalence of proof predicates *)

Lemma llpol2llpolfrag : forall l, llpol l ->
  ll_def.ll pfrag_mell (map llpol2ll l).
Proof with try eassumption ; try reflexivity.
intros l pi ; induction pi ; try now (constructor ; intuition).
- eapply ll_def.ex_r...
  apply Permutation_Type_map...
- eapply ll_def.ex_r.
  + apply (ll_def.tens_r _ _ _ _ _ IHpi1 IHpi2).
  + simpl ; perm_Type_solve.
- simpl ; rewrite ? map_app.
  rewrite llpol2ll_map_wn.
  apply ll_def.oc_r.
  rewrite <- llpol2ll_map_wn...
Qed.

Lemma llpolfrag2llpol : forall l,
  ll_def.ll pfrag_mell (map llpol2ll l) -> llpol l.
Proof with try reflexivity.
intros l pi.
remember (map llpol2ll l) as l0.
revert l Heql0 ; induction pi ; intros l' Heql0 ; subst ;
  try (now (destruct l' ; inversion Heql0 ;
            destruct f ; inversion H0 ;
              [ destruct p | destruct n ] ; inversion H0 ; subst ;
            constructor ;
            apply IHpi ; reflexivity)) ;
  try (now inversion f).
- decomp_map_Type Heql0 ; subst.
  destruct l1 ; inversion Heql4.
  destruct x ; inversion Heql2 ;
    [ destruct p | destruct n ] ; inversion Heql2.
  destruct x0 ; inversion Heql0 ;
    [destruct p | destruct n ] ; inversion Heql0.
  subst ; subst.
  apply ax_r.
- simpl in p.
  apply Permutation_Type_map_inv in p.
  destruct p as [l'' Heq HP] ; subst.
  symmetry in HP.
  eapply ex_r ; [ | eassumption ].
  apply IHpi...
- decomp_map_Type Heql0 ; subst.
  simpl in Heql0 ; apply llpol2ll_map_wn_inv in Heql0 ;
    destruct Heql0 as [l Heq1 Heq2] ; subst.
  apply Permutation_Type_map_inv in p ; destruct p as [l' Heq HP] ; subst.
  apply (Permutation_Type_map wn) in HP.
  apply (Permutation_Type_map neg) in HP.
  eapply ex_r.
  + rewrite <- llpol2ll_map_wn in IHpi.
    apply IHpi ; rewrite <- ? map_app...
  + perm_Type_solve.
- destruct l' ; inversion Heql0.
  destruct f ; inversion H0 ;
    [ destruct p | destruct n ] ; inversion H0.
  destruct l' ; inversion H1.
  apply one_r.
- decomp_map_Type Heql0 ; subst.
  destruct x ; inversion Heql2 ;
    [ destruct p | destruct n ] ; inversion Heql2 ; subst.
  eapply ex_r.
  apply tens_r.
  + apply IHpi1...
  + apply IHpi2...
  + perm_Type_solve.
- destruct l' ; inversion Heql0.
  destruct f ; inversion H0 ;
    [ destruct p | destruct n ] ; inversion H0 ; subst.
  apply with_r.
  + apply IHpi1...
  + apply IHpi2...
- destruct l' ; inversion Heql0.
  destruct f ; inversion H0 ;
    [destruct p | destruct n ] ; inversion H0 ; subst.
  apply llpol2ll_map_wn_inv in H1.
  destruct H1 as [l'' Heq1 Heq2] ; subst.
  apply oc_r.
  apply IHpi.
  simpl ; rewrite llpol2ll_map_wn...
- inversion a.
Qed.

(** ** 6. import properties *)

(** *** axiom expansion *)

Lemma ax_gen_r : forall A, llpol (dual A :: A :: nil).
Proof.
intro A.
eapply ex_r ; [ | apply Permutation_Type_swap ].
apply llpolfrag2llpol.
simpl ; rewrite <- llpol2ll_dual.
apply ll_def.ax_exp.
Qed.

(** *** cut admissibility *)

Lemma cut_r : forall A l1 l2,
  llpol (A :: l1) -> llpol (dual A :: l2) -> llpol (l1 ++ l2).
Proof with try eassumption.
intros A l1 l2 pi1 pi2.
apply llpol2llpolfrag in pi1 ; simpl in pi1.
apply llpol2llpolfrag in pi2 ; simpl in pi2.
eapply ll_cut.cut_r_axfree in pi1 ;
  [ | | rewrite llpol2ll_dual ]...
- rewrite <- map_app in pi1.
  eapply llpolfrag2llpol...
- intros Hax ; inversion Hax.
Qed.

(** ** 7. specific developments *)

Lemma par_inv : forall N M l,
  llpol (neg (parr N M) :: l) -> llpol (neg N :: neg M :: l).
Proof with try assumption.
intros N M l pi.
rewrite <- (app_nil_l l).
eapply ex_r ; [ | apply Permutation_Type_swap ].
rewrite 2 app_comm_cons.
eapply cut_r.
- rewrite <- (app_nil_l (neg N :: nil)).
  rewrite 2 app_comm_cons.
  rewrite <- app_comm_cons.
  apply (tens_r (ndual M) (ndual N)).
  + change (pos (ndual M)) with (dual (neg M)).
    apply ax_gen_r.
  + change (pos (ndual N)) with (dual (neg N)).
    apply ax_gen_r.
- simpl ; rewrite 2 (proj2 bipndual)...
Qed.

Lemma with_inv_1 : forall N M l,
  llpol (neg (awith N M) :: l) ->  llpol (neg N :: l).
Proof with try assumption.
intros N M l pi.
rewrite <- (app_nil_l l).
rewrite app_comm_cons.
eapply cut_r.
- apply (plus_r1 (ndual N) (ndual M)).
  change (pos (ndual N)) with (dual (neg N)).
  apply ax_gen_r.
- simpl ; rewrite 2 (proj2 bipndual)...
Qed.

Lemma with_inv_2 : forall N M l,
  llpol (neg (awith M N) :: l) ->  llpol (neg N :: l).
Proof with try assumption.
intros N M l pi.
rewrite <- (app_nil_l l).
rewrite app_comm_cons.
eapply cut_r.
- apply (plus_r2 (ndual N) (ndual M)).
  change (pos (ndual N)) with (dual (neg N)).
  apply ax_gen_r.
- simpl ; rewrite 2 (proj2 bipndual)...
Qed.

(** Polarized sequents are those with at most one positive formula. *)
Definition polsequent l :=
 sum { l0 | l = map neg l0 }
     { lP & Permutation_Type l (pos (snd lP) :: (map neg (fst lP))) }.

Lemma uniq_polsequent : forall l1 l2 P1 P2,
  Permutation_Type (pos P1 :: l1) (pos P2 :: map neg l2) ->
    { l1' : _ & l1 = map neg l1' & prod (P1 = P2) (Permutation_Type l1' l2) }.
Proof with try eassumption ; try reflexivity.
intros l1 l2 P1 P2 HP.
assert (HP' := HP).
symmetry in HP'.
apply Permutation_Type_vs_cons_inv in HP'.
destruct HP' as ((l' & l'') & Heq) ; simpl in Heq.
destruct l' ; inversion Heq ; subst.
- apply Permutation_Type_cons_inv in HP.
  apply Permutation_Type_map_inv in HP.
  destruct HP as [l Heq' HP'] ; subst.
  exists l ; [ | split ]...
  symmetry...
- exfalso.
  symmetry in H1.
  decomp_map H1.
  inversion H1.
Qed.

(*
Lemma polsequent_app : forall l1 l2,
  polsequent (l1 ++ l2) ->
    { l & sum (prod (l2 = map neg l) (polsequent l1))
              (prod (l1 = map neg l) (polsequent l2)) }.
Proof with try eassumption ; try reflexivity.
intros l1 l2 Hi.
assert (Hi' := Hi).
destruct Hi' as [ (l0 & Hi') | ((l0 & P) & Hi') ].
- decomp_map_Type Hi' ; subst.
  exists l4 ; left ; split...
  left ; eexists...
- assert (Hi'' := Hi').
  apply Permutation_Type_vs_cons_inv in Hi'.
  destruct Hi' as ((l3 & l4) & Heq).
  dichot_Type_elt_app_exec Heq ; subst.
  + list_simpl in Hi''.
    symmetry in Hi''.
    apply Permutation_Type_cons_app_inv in Hi''.
    symmetry in Hi''.
    apply Permutation_Type_map_inv in Hi''.
    destruct Hi'' as [l' Heq HP].
    decomp_map_Type Heq ; subst.
    eexists ; left ; split...
    right ; exists (l5 ++ l7, P) ; perm_Type_solve.
  + symmetry in Hi''.
    rewrite app_assoc in Hi''.
    apply Permutation_Type_cons_app_inv in Hi''.
    list_simpl in Hi''.
    symmetry in Hi''.
    apply Permutation_Type_map_inv in Hi''.
    destruct Hi'' as [l' Heq HP].
    decomp_map_Type Heq ; subst.
    eexists ; right ; split...
    right ; exists (l7 ++ l8, P) ; perm_Type_solve.
Qed.
*)

Lemma polsequent_neg_add : forall N l,
  polsequent l -> polsequent (neg N :: l).
Proof.
intros N l [ (l0 & Heq) | ((l0 & P) & HP) ] ; subst.
- left ; exists (N :: l0) ; reflexivity.
- assert (HP' := HP).
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq) ; subst.
  symmetry in HP.
  apply Permutation_Type_cons_app_inv in HP.
  symmetry in HP.
  apply Permutation_Type_map_inv in HP.
  destruct HP as [l1 Heq' _].
  list_simpl in Heq' ; decomp_map_Type Heq' ; subst.
  right ; exists (N :: l4 ++ l5, P) ; perm_Type_solve.
Qed.

Lemma polsequent_neg_rem : forall N l,
  polsequent (neg N :: l) -> polsequent l.
Proof.
intros N l Hpol.
destruct Hpol as [ (l0 & Heq) | ((l0 & P) & HP) ] ; subst.
- destruct l0 ; inversion Heq.
  left ; exists l0 ; reflexivity.
- assert (HP' := HP).
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq ; subst.
  symmetry in HP.
  rewrite app_comm_cons in HP.
  apply Permutation_Type_cons_app_inv in HP.
  symmetry in HP.
  apply Permutation_Type_map_inv in HP.
  destruct HP as [l1 Heq' _].
  list_simpl in Heq' ; decomp_map_Type Heq' ; subst.
  right ; exists (l5 ++ l6, P) ; perm_Type_solve.
Qed.

Lemma polsequent_pos_rem : forall P l,
  polsequent (pos P :: l) -> { l' | l = map neg l' }.
Proof with try reflexivity.
intros P l Hs.
destruct Hs as [ (l0 & Heq) | ((l0 & Q) & HP) ].
- decomp_map_Type Heq ; inversion Heq1.
- assert (HP' := HP).
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l' & l'') & Heq).
  destruct l' ; inversion Heq ; subst.
  + apply Permutation_Type_cons_inv in HP.
    apply Permutation_Type_map_inv in HP...
    destruct HP as [l' Heq' HP'] ; subst.
    eexists...
  + exfalso.
    symmetry in HP.
    rewrite app_comm_cons in HP.
    apply Permutation_Type_cons_app_inv in HP.
    symmetry in HP.
    apply Permutation_Type_map_inv in HP.
    destruct HP as [l2 Heq' HP'].
    destruct l2 ; inversion Heq'.
Qed.

Lemma polsequent_dec : forall l, polsequent l + (polsequent l -> False).
Proof.
induction l.
- left ; left ; exists nil ; reflexivity.
- destruct a.
  + destruct IHl.
    * destruct p0.
      -- destruct s as [l0 Heq] ; subst.
         left ; right ; exists (l0,p) ; reflexivity.
      -- destruct s as [[l0 P] HP].
         right ; intros Hps ; destruct Hps.
         ++ destruct s as [l1 Heq] ; subst.
            destruct l1 ; inversion Heq.
         ++ destruct s as [[l1 Q] HP'].
            apply uniq_polsequent in HP'.
            destruct HP' as [l' Heq [Heq' HP']] ; subst.
            simpl in HP ; symmetry in HP.
            apply Permutation_Type_map_inv in HP.
            destruct HP as [l Heq _].
            destruct l ; inversion Heq.
    * right ; intros Hps.
      apply f.
      left ; eapply polsequent_pos_rem ; eassumption.
  + destruct IHl.
    * left.
      apply polsequent_neg_add ; assumption.
    * right ; intros Hps.
      apply f ; clear f.
      eapply polsequent_neg_rem ; eassumption.
Qed.

Definition polsequent_bool l :=
match polsequent_dec l with
| inl _ => true
| inr _ => false
end.

Lemma true_polsequent : forall l,
  polsequent_bool l = true -> polsequent l.
Proof.
intros l Hb ; unfold polsequent_bool in Hb ; destruct (polsequent_dec l).
- assumption.
- inversion Hb.
Qed.

Lemma polsequent_true : forall l,
  polsequent l -> polsequent_bool l = true.
Proof.
intros l Hp.
unfold polsequent_bool ; destruct (polsequent_dec l) ; intuition.
Qed.

(** Version of [llpol] with a predicate parameter for constraining sequents inside proofs. *)
Inductive llpol_ps PS : list formula -> Type :=
| ax_ps_r : forall X, is_true (PS (neg (covar X) :: pos (var X) :: nil)) ->
                llpol_ps PS (neg (covar X) :: pos (var X) :: nil)
| ex_ps_r : forall l1 l2, is_true (PS l2) ->
                llpol_ps PS l1 -> Permutation_Type l1 l2 -> llpol_ps PS l2
| one_ps_r : is_true (PS (pos one :: nil)) -> llpol_ps PS (pos one :: nil)
| bot_ps_r : forall l, is_true (PS (neg bot :: l)) ->
                llpol_ps PS l -> llpol_ps PS (neg bot :: l)
| tens_ps_r : forall P Q l1 l2, is_true (PS (pos (tens P Q) :: l1 ++ l2)) ->
                llpol_ps PS (pos P :: l1) -> llpol_ps PS (pos Q :: l2) ->
                llpol_ps PS (pos (tens P Q) :: l1 ++ l2)
| parr_ps_r : forall N M l, is_true (PS (neg (parr N M) :: l)) ->
                llpol_ps PS (neg N :: neg M :: l) ->
                llpol_ps PS (neg (parr N M) :: l)
| top_ps_r : forall l, is_true (PS (neg top :: l)) -> llpol_ps PS (neg top :: l)
| plus_ps_r1 : forall P Q l, is_true (PS (pos (aplus P Q) :: l)) ->
                llpol_ps PS (pos P :: l)-> llpol_ps PS (pos (aplus P Q) :: l)
| plus_ps_r2 : forall P Q l, is_true (PS (pos (aplus Q P) :: l)) ->
                llpol_ps PS (pos P :: l)-> llpol_ps PS (pos (aplus Q P) :: l)
| with_ps_r : forall N M l, is_true (PS (neg (awith N M) :: l)) ->
                llpol_ps PS (neg N :: l) -> llpol_ps PS (neg M :: l) ->
                llpol_ps PS (neg (awith N M) :: l)
| oc_ps_r : forall N l, is_true (PS (pos (oc N) :: map neg (map wn l))) ->
                llpol_ps PS (neg N :: map neg (map wn l)) ->
                llpol_ps PS (pos (oc N) :: map neg (map wn l))
| de_ps_r : forall P l, is_true (PS (neg (wn P) :: l)) ->
                llpol_ps PS (pos P :: l) -> llpol_ps PS (neg (wn P) :: l)
| wk_ps_r : forall P l, is_true (PS (neg (wn P) :: l)) ->
                llpol_ps PS l -> llpol_ps PS (neg (wn P) :: l)
| co_ps_r : forall P l, is_true (PS (neg (wn P) :: l)) ->
                llpol_ps PS (neg (wn P) :: neg (wn P) :: l) ->
                llpol_ps PS (neg (wn P) :: l).

Lemma llpol_ps_is_ps : forall l PS, llpol_ps PS l -> is_true (PS l).
Proof.
intros l PS Hll.
inversion Hll ; assumption.
Qed.

Lemma llpol_ps_is_llpol : forall l PS, llpol_ps PS l -> llpol l.
Proof with try eassumption.
intros l PS pi.
induction pi ;
  try (destruct IHpi as [s IHpi]) ;
  try (destruct IHpi1 as [s1 IHpi1]) ;
  try (destruct IHpi2 as [s2 IHpi2]) ;
  try (constructor ; eassumption ; fail).
eapply ex_r...
Qed.

Lemma llpol_is_llpol_ps : forall l, llpol l -> llpol_ps (fun _ => true) l.
Proof with try eassumption ; try reflexivity.
intros l pi.
induction pi ;
  try (constructor ; try assumption ; try reflexivity ; fail).
eapply ex_ps_r...
Qed.

(** Formulas with [top] below negative connectives only. Such formulas are equivalent to [top]. *)
Inductive top_surf : nformula -> Type :=
| top_s : top_surf top
| par_ls : forall N M, top_surf N -> top_surf (parr N M)
| par_rs : forall N M, top_surf N -> top_surf (parr M N)
| with_s : forall N M, top_surf N -> top_surf M -> top_surf (awith N M).

Lemma top_imp_top_surf_ps : forall N l,
  top_surf N -> polsequent l -> llpol_ps polsequent_bool (neg N :: l).
Proof with try eassumption.
induction N ; intros l Ht Hp ; inversion Ht ; subst.
- eapply IHN1 in H0.
  + apply parr_ps_r...
    apply llpol_ps_is_ps in H0.
    apply true_polsequent in H0.
    apply polsequent_true.
    apply polsequent_neg_add.
    eapply polsequent_neg_rem.
    eapply polsequent_neg_rem...
  + apply polsequent_neg_add...
- eapply IHN2 in H0.
  apply parr_ps_r ; [ | eapply ex_ps_r ; [ | | now apply Permutation_Type_swap ]]...
  + apply llpol_ps_is_ps in H0.
    apply true_polsequent in H0.
    apply polsequent_true.
    apply polsequent_neg_add.
    eapply polsequent_neg_rem.
    eapply polsequent_neg_rem...
  + apply llpol_ps_is_ps in H0.
    apply true_polsequent in H0.
    apply polsequent_true.
    apply polsequent_neg_add.
    apply polsequent_neg_add.
    eapply polsequent_neg_rem.
    eapply polsequent_neg_rem...
  + apply polsequent_neg_add...
- apply top_ps_r.
    apply polsequent_true.
  apply polsequent_neg_add...
- apply with_ps_r.
  + apply polsequent_true.
    apply polsequent_neg_add...
  + eapply IHN1 in H1...
  + eapply IHN2 in H2...
Qed.

Lemma bipos_top_surf : forall l,
  llpol l -> forall P Q l', Permutation_Type l (pos P :: pos Q :: l') ->
    { Nll : _ & l' = fst (snd Nll) ++ neg (fst Nll) :: snd (snd Nll)
              & top_surf (fst Nll) }.
Proof with try assumption ; try reflexivity.
intros l pi ; induction pi ; intros P' Q' l' HP.
- apply Permutation_Type_length_2_inv in HP.
  destruct HP as [ HP | HP ] ; inversion HP.
- eapply IHpi.
  etransitivity ; [ apply p | apply HP ].
- apply Permutation_Type_length_1_inv in HP.
  inversion HP.
- assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq.
  destruct l2 ; inversion H1 ; subst.
  rewrite 2 app_comm_cons in HP.
  apply Permutation_Type_cons_app_inv in HP.
  list_simpl in HP.
  apply IHpi in HP.
  destruct HP as [(N & l0 & l1) Heq' Htop].
  dichot_Type_elt_app_exec Heq' ; subst.
  + exists (N,(l0,l4 ++ neg bot :: l3)) ; list_simpl...
  + exists (N,(l2 ++ neg bot :: l5,l1)) ; list_simpl...
- assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2' & l3') & Heq).
  destruct l2' ; inversion Heq ; subst.
  + apply Permutation_Type_cons_inv in HP.
    assert (HP' := HP).
    apply Permutation_Type_vs_cons_inv in HP'.
    destruct HP' as ((l3 & l4) & Heq').
    rewrite Heq' in HP.
    symmetry in HP.
    apply Permutation_Type_cons_app_inv in HP.
    dichot_Type_app_exec Heq' ;
      [ | destruct l0 ; inversion Heq'1 ; list_simpl in Heq'1 ] ;
        simpl in Heq'0 ; subst.
    * list_simpl in HP.
      assert (Permutation_Type (pos Q :: l ++ pos Q' :: l4)
                               (pos Q :: pos Q' :: l ++ l4))
        as HP' by perm_Type_solve.
      apply IHpi2 in HP'.
      destruct HP' as [(N & l5 & l6) Heq' Htop] ; simpl in Heq'.
      rewrite Heq' in HP.
      rewrite app_assoc in HP.
      apply Permutation_Type_vs_elt_inv in HP.
      destruct HP as ((l7 & l8) & Heq'').
      exists (N,(l7,l8))...
    * destruct (IHpi2 Q Q' l4 (Permutation_Type_refl _))
        as [(N & l5 & l6) Heq' Htop] ; subst ; simpl in HP.
      rewrite app_assoc in HP.
      apply Permutation_Type_vs_elt_inv in HP.
      destruct HP as ((l7 & l8) & Heq'').
      exists (N,(l7,l8))...
    * assert (Permutation_Type (pos P :: l3 ++ pos Q' :: l0)
                               (pos P :: pos Q' :: l3 ++ l0))
        as HP' by perm_Type_solve.
      apply IHpi1 in HP'.
      destruct HP' as [(N & l5 & l6) Heq' Htop] ;
        simpl in Heq' ; simpl in HP.
      rewrite app_assoc in HP.
      rewrite Heq' in HP.
      list_simpl in HP.
      apply Permutation_Type_vs_elt_inv in HP.
      destruct HP as ((l7 & l8) & Heq'').
      exists (N,(l7,l8))...
  + destruct l2' ; inversion H1 ; subst.
    * rewrite <- (app_nil_l (pos (tens _ _) :: l3')) in HP.
      rewrite (app_comm_cons _ _ (pos P')) in HP.
      apply Permutation_Type_cons_app_inv in HP.
      list_simpl in HP.
      destruct (Permutation_Type_vs_cons_inv _ _ _ HP) as ((l4 & l5) & Heq').
      dichot_Type_app_exec Heq' ;
        [ | destruct l0 ; inversion Heq'1 ; list_simpl in Heq'1 ] ;
          simpl in Heq'1 ; simpl in HP ; subst.
      -- symmetry in HP.
         rewrite app_assoc in HP.
         apply Permutation_Type_cons_app_inv in HP.
         list_simpl in HP.
         assert (Permutation_Type (pos Q :: l ++ pos P' :: l5)
                                  (pos Q :: pos P' :: l ++ l5))
           as HP' by perm_Type_solve.
         apply IHpi2 in HP'.
         destruct HP' as [(N & l6 & l7) Heq' Htop].
         rewrite Heq' in HP.
         rewrite app_assoc in HP.
         apply Permutation_Type_vs_elt_inv in HP.
         destruct HP as ((l8 & l9) & Heq'').
         exists (N,(l8,l9))...
      -- destruct (IHpi2 Q P' l5 (Permutation_Type_refl _))
           as [(N & l6 & l7) Heq' Htop] ; subst.
         list_simpl in HP.
         symmetry in HP.
         apply Permutation_Type_cons_app_inv in HP.
         rewrite app_assoc in HP.
         apply Permutation_Type_vs_elt_inv in HP.
         destruct HP as ((l8 & l9) & Heq'').
         exists (N,(l8,l9))...
      -- assert (Permutation_Type (pos P :: l4 ++ pos P' :: l0)
                                  (pos P :: pos P' :: l4 ++ l0))
           as HP' by perm_Type_solve.
         apply IHpi1 in HP'.
         destruct HP' as [(N & l6 & l7) Heq' Htop].
         list_simpl in HP.
         symmetry in HP.
         apply Permutation_Type_cons_app_inv in HP.
         rewrite app_assoc in HP.
         rewrite Heq' in HP.
         list_simpl in HP.
         apply Permutation_Type_vs_elt_inv in HP.
         destruct HP as ((l8 & l9) & Heq'').
         exists (N,(l8,l9))...
    * rewrite 2 (app_comm_cons _ (pos (tens _ _) :: l3')) in HP.
      apply Permutation_Type_cons_app_inv in HP.
      list_simpl in HP.
      destruct (Permutation_Type_vs_cons_inv _ _ _ HP) as ((l4 & l5) & Heq').
      dichot_Type_app_exec Heq' ; subst.
      -- assert (Permutation_Type (pos Q :: l ++ pos P' :: l5)
                                  (pos Q :: pos P' :: l ++ l5))
           as HP' by perm_Type_solve.
         apply IHpi2 in HP'.
         destruct HP' as [(N & l6 & l7) Heq' Htop].
         symmetry in HP.
         rewrite app_assoc in HP.
         apply Permutation_Type_cons_app_inv in HP.
         list_simpl in HP.
         rewrite Heq' in HP.
         rewrite app_assoc in HP.
         apply Permutation_Type_vs_elt_inv in HP.
         destruct HP as ((l8 & l9) & Heq'').
         destruct l8 ; inversion Heq''.
         dichot_Type_app_exec H2 ;
           [ | destruct l2 ; inversion Heq'' ; list_simpl in H4 ] ; subst.
         ++ exists (N,(l2' ++ pos (tens P Q) :: l0,l9)) ; list_simpl...
         ++ exists (N,(l8 ++ pos (tens P Q) :: nil,l9)) ; list_simpl...
         ++ inversion H4 ; subst.
            exists (N,(l8,l2 ++ pos (tens P Q) :: l3')) ; list_simpl...
      -- destruct l0 ; inversion Heq'1 ; list_simpl in Heq'1 ; subst.
         ++ destruct (IHpi2 Q P' l5 (Permutation_Type_refl _))
              as [(N & l6 & l7) Heq' Htop] ; subst.
            list_simpl in HP.
            symmetry in HP.
            apply Permutation_Type_cons_app_inv in HP.
            rewrite app_assoc in HP.
            apply Permutation_Type_vs_elt_inv in HP.
            destruct HP as ((l8 & l9) & Heq'').
            destruct l8 ; inversion Heq'' ; subst.
            dichot_Type_app_exec H3 ;
              [ | destruct l0 ; inversion H2 ; list_simpl in H2 ] ; subst.
            ** exists (N,(l2' ++ pos (tens P Q) :: l,l9)) ; list_simpl...
            ** exists (N,(l8 ++ pos (tens P Q) :: nil,l9)) ; list_simpl...
            ** exists (N,(l8,l0 ++ pos (tens P Q) :: l3')) ; list_simpl...
         ++ assert (Permutation_Type (pos P :: l4 ++ pos P' :: l0)
                                     (pos P :: pos P' :: l4 ++ l0))
              as HP' by perm_Type_solve.
            apply IHpi1 in HP'.
            destruct HP' as [(N & l6 & l7) Heq' Htop].
            symmetry in HP.
            list_simpl in HP.
            apply Permutation_Type_cons_app_inv in HP.
            rewrite app_assoc in HP.
            rewrite Heq' in HP.
            list_simpl in HP.
            apply Permutation_Type_vs_elt_inv in HP.
            destruct HP as ((l8 & l9) & Heq'').
            destruct l8 ; inversion Heq''.
            dichot_Type_app_exec H2 ;
              [ | destruct l1 ; inversion H4 ; list_simpl in H4 ] ; subst.
            ** exists (N,(l2' ++ pos (tens P Q) :: l,l9)) ; list_simpl...
            ** exists (N,(l8 ++ pos (tens P Q) :: nil,l9)) ; list_simpl...
            ** exists (N,(l8,l1 ++ pos (tens P Q) :: l3')) ; list_simpl...
- assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq.
  destruct l2 ; inversion H1 ; subst.
  rewrite 2 app_comm_cons in HP.
  apply Permutation_Type_cons_app_inv in HP.
  apply (Permutation_Type_cons_app _ _ (neg M)) in HP.
  apply (Permutation_Type_cons_app _ _ (neg N)) in HP.
  list_simpl in HP.
  apply IHpi in HP.
  destruct HP as [(N' & l0 & l1) Heq' Htop].
  dichot_Type_elt_app_exec Heq' ; subst.
  + destruct l4 ; inversion Heq'1 ; subst.
    * exists (parr N N',(l2,l1)) ; list_simpl...
      apply par_rs...
    * exists (N',(l2 ++ neg (parr N M) :: l4,l1)) ; list_simpl...
  + destruct l5 ; inversion Heq'1 ; subst.
    * exists (parr N' M,(l0,l3)) ; list_simpl...
      apply par_ls...
    * exists (N',(l0,l5 ++ neg (parr N M) :: l3)) ; list_simpl...
- symmetry in HP.
  apply Permutation_Type_vs_cons_inv in HP.
  destruct HP as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq.
  destruct l2 ; inversion H1 ; subst.
  exists (top,(l2,l3))...
  apply top_s.
- assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq ; subst.
  + apply Permutation_Type_cons_inv in HP.
    apply (@Permutation_Type_cons _ _ (pos P) eq_refl) in HP.
    apply IHpi in HP.
    destruct HP as [(N & l0 & l1) Heq' Htop] ; subst.
    exists (N,(l0,l1))...
  + destruct l2 ; inversion H1 ; subst.
    * rewrite <- (app_nil_l (pos (aplus _ _) :: l3)) in HP.
      rewrite app_comm_cons in HP.
      apply Permutation_Type_cons_app_inv in HP.
      apply (@Permutation_Type_cons _ _ (pos P) eq_refl) in HP.
      list_simpl in HP.
      apply IHpi in HP.
      destruct HP as [(N & l0 & l1) Heq' Htop] ; subst.
      exists (N,(l0,l1))...
    * rewrite 2 app_comm_cons in HP.
      apply Permutation_Type_cons_app_inv in HP.
      apply (Permutation_Type_cons_app _ _ (pos P)) in HP.
      list_simpl in HP.
      apply IHpi in HP.
      destruct HP as [(N' & l0 & l1) Heq' Htop].
      dichot_Type_elt_app_exec Heq' ; subst.
      -- exists (N',(l2 ++ pos (aplus P Q) :: l4,l1)) ; list_simpl...
      -- destruct l5 ; inversion Heq'1 ; subst.
         exists (N',(l0,l5 ++ pos (aplus P Q) :: l3)) ; list_simpl...
- assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq ; subst.
  + apply Permutation_Type_cons_inv in HP.
    apply (@Permutation_Type_cons _ _ (pos P) eq_refl) in HP.
    apply IHpi in HP.
    destruct HP as [(N & l0 & l1) Heq' Htop] ; subst.
    exists (N,(l0,l1))...
  + destruct l2 ; inversion H1 ; subst.
    * rewrite <- (app_nil_l (pos (aplus _ _) :: l3)) in HP.
      rewrite app_comm_cons in HP.
      apply Permutation_Type_cons_app_inv in HP.
      apply (@Permutation_Type_cons _ _ (pos P) eq_refl) in HP.
      list_simpl in HP.
      apply IHpi in HP.
      destruct HP as [(N & l0 & l1) Heq' Htop] ; subst.
      exists (N,(l0,l1))...
    * rewrite 2 app_comm_cons in HP.
      apply Permutation_Type_cons_app_inv in HP.
      apply (Permutation_Type_cons_app _ _ (pos P)) in HP.
      list_simpl in HP.
      apply IHpi in HP.
      destruct HP as [(N' & l0 & l1) Heq' Htop].
      dichot_Type_elt_app_exec Heq' ; subst.
      -- exists (N',(l2 ++ pos (aplus Q P) :: l4,l1)) ; list_simpl...
      -- destruct l5 ; inversion Heq'1 ; subst.
         exists (N',(l0,l5 ++ pos (aplus Q P) :: l3)) ; list_simpl...
- assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq.
  destruct l2 ; inversion H1 ; subst.
  rewrite 2 app_comm_cons in HP.
  apply Permutation_Type_cons_app_inv in HP.
  assert (HP1 := (Permutation_Type_cons_app _ _ (neg N) HP)).
  assert (HP2 := (Permutation_Type_cons_app _ _ (neg M) HP)).
  list_simpl in HP1 ; apply IHpi1 in HP1.
  list_simpl in HP2 ; apply IHpi2 in HP2.
  destruct HP1 as [(N' & l0 & l1) Heq' Htop].
  destruct HP2 as [(M' & l0' & l1') Heq'' Htop'].
  dichot_Type_elt_app_exec Heq' ; subst.
  + exists (N',(l2 ++ neg (awith N M) :: l4,l1)) ; list_simpl...
  + destruct l5 ; inversion Heq'1 ; subst.
    * list_simpl in Heq''.
      dichot_Type_elt_app_exec Heq'' ; subst.
      -- exists (M',(l0 ++ neg (awith N' M) :: l2,l1')) ; list_simpl...
      -- destruct l3 ; inversion Heq''1 ; subst.
         ++ exists (awith N' M',(l0',l1')) ;list_simpl...
            apply with_s...
         ++ exists (M',(l0',l3 ++ neg (awith N' M) :: l1)) ; list_simpl...
    * exists (N',(l0,l5 ++ neg (awith N M) :: l3)) ; list_simpl...
- exfalso.
  assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq ; subst.
  + apply Permutation_Type_cons_inv in HP.
    apply Permutation_Type_vs_cons_inv in HP.
    destruct HP as ((l2 & l3) & Heq').
    symmetry in Heq'.
    decomp_map Heq'.
    discriminate Heq'3.
  + destruct l2 ; inversion H1 ; subst.
    * rewrite <- (app_nil_l (pos (oc _) :: l3)) in HP.
      rewrite app_comm_cons in HP.
      apply Permutation_Type_cons_app_inv in HP.
      apply Permutation_Type_vs_cons_inv in HP.
      destruct HP as ((l2' & l3') & Heq').
      symmetry in Heq'.
      decomp_map Heq'.
      discriminate Heq'3.
    * rewrite 2 app_comm_cons in HP.
      apply Permutation_Type_cons_app_inv in HP.
      apply Permutation_Type_vs_cons_inv in HP.
      destruct HP as ((l2' & l3') & Heq').
      symmetry in Heq'.
      decomp_map Heq'.
      discriminate Heq'3.
- assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq.
  destruct l2 ; inversion H1 ; subst.
  rewrite 2 app_comm_cons in HP.
  apply Permutation_Type_cons_app_inv in HP.
  apply (Permutation_Type_cons_app _ _ (pos P)) in HP.
  list_simpl in HP.
  apply IHpi in HP.
  destruct HP as [(N' & l0 & l1) Heq' Htop].
  dichot_Type_elt_app_exec Heq' ; subst.
  + exists (N',(l2 ++ neg (wn P) :: l4,l1)) ; list_simpl...
  + destruct l5 ; inversion Heq'1 ; subst.
    exists (N',(l0,l5 ++ neg (wn P) :: l3)) ; list_simpl...
- assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq.
  destruct l2 ; inversion H1 ; subst.
  rewrite 2 app_comm_cons in HP.
  apply Permutation_Type_cons_app_inv in HP.
  list_simpl in HP.
  apply IHpi in HP.
  destruct HP as [(N & l0 & l1) Heq' Htop].
  dichot_Type_elt_app_exec Heq' ; subst.
  + exists (N,(l0,l4 ++ neg (wn P) :: l3)) ; list_simpl...
  + exists (N,(l2 ++ neg (wn P) :: l5,l1)) ; list_simpl...
- assert (HP' := HP).
  symmetry in HP'.
  apply Permutation_Type_vs_cons_inv in HP'.
  destruct HP' as ((l2 & l3) & Heq).
  destruct l2 ; inversion Heq.
  destruct l2 ; inversion H1 ; subst.
  rewrite 2 app_comm_cons in HP.
  apply Permutation_Type_cons_app_inv in HP.
  apply (Permutation_Type_cons_app _ _ (neg (wn P))) in HP.
  apply (Permutation_Type_cons_app _ _ (neg (wn P))) in HP.
  list_simpl in HP.
  apply IHpi in HP.
  destruct HP as [(N' & l0 & l1) Heq' Htop].
  dichot_Type_elt_app_exec Heq' ; subst.
  + destruct l4 ; inversion Heq'1 ; subst.
    * inversion Htop.
    * exists (N',(l2 ++ neg (wn P) :: l4,l1)) ; list_simpl...
  + destruct l5 ; inversion Heq'1 ; subst.
    * inversion Htop.
    * exists (N',(l0,l5 ++ neg (wn P) :: l3)) ; list_simpl...
Qed.

Theorem llpol_is_ll_polsequent : forall l,
  llpol l -> polsequent l -> llpol_ps polsequent_bool l.
Proof with try eassumption ; try reflexivity.
intros l pi.
induction pi ; intros Hpol.
- constructor.
  apply polsequent_true.
  right.
  exists (covar X :: nil,var X).
  apply Permutation_Type_swap.
- eapply ex_ps_r ; [ apply polsequent_true | | ]...
  apply IHpi.
  destruct Hpol as [ (l0 & Heq) | ((l0 & P) & HP) ] ; subst.
  + apply Permutation_Type_map_inv in p.
    destruct p as [l Heq _] ; subst.
    left ; eexists...
  + assert (HP' := HP).
    apply Permutation_Type_vs_cons_inv in HP'.
    destruct HP' as ((l3 & l4) & Heq) ; subst.
    symmetry in HP.
    apply Permutation_Type_cons_app_inv in HP.
    symmetry in HP.
    apply Permutation_Type_map_inv in HP.
    destruct HP as [l Heq HP].
    decomp_map_Type Heq ; simpl in Heq1 ; simpl in Heq2 ;
      subst ; simpl in p.
    right ; exists (l5 ++ l6,P) ; simpl ; perm_Type_solve.
- constructor.
  apply polsequent_true.
  right ; exists (nil,one)...
- constructor ; [ apply polsequent_true | ]...
  apply IHpi.
  eapply polsequent_neg_rem...
- apply polsequent_pos_rem in Hpol.
  destruct Hpol as [ l' Heq ].
  decomp_map_Type Heq ; subst.
  constructor...
  + apply polsequent_true.
    right ; exists (l0 ++ l3,tens P Q) ; perm_Type_solve.
  + apply IHpi1.
    right ; exists (l0,P) ; perm_Type_solve.
  + apply IHpi2.
    right ; exists (l3,Q) ; perm_Type_solve.
- constructor ; [ apply polsequent_true | ]...
  apply IHpi.
  apply polsequent_neg_add.
  apply polsequent_neg_add.
  eapply polsequent_neg_rem...
- constructor ; apply polsequent_true...
- assert (Hpol' := Hpol).
  apply polsequent_pos_rem in Hpol'.
  destruct Hpol' as [ l' Heq ] ; subst.
  constructor ; [ apply polsequent_true | ]...
  apply IHpi.
  right ; exists (l',P) ; perm_Type_solve.
- assert (Hpol' := Hpol).
  apply polsequent_pos_rem in Hpol'.
  destruct Hpol' as [ l' Heq ] ; subst.
  apply plus_ps_r2 ; [ apply polsequent_true | ]...
  apply IHpi.
  right ; exists (l',P) ; perm_Type_solve.
- constructor ; [ apply polsequent_true | | ]...
  + apply IHpi1.
    apply polsequent_neg_add.
    eapply polsequent_neg_rem...
  + apply IHpi2.
    apply polsequent_neg_add.
    eapply polsequent_neg_rem...
- constructor ; [ apply polsequent_true | ]...
  apply IHpi.
  left ; exists (N :: map wn l)...
- destruct Hpol as [ (l0 & Heq) | ((l0 & Q) & HP) ] ; subst.
  + apply de_ps_r.
    * apply polsequent_true.
      left ; rewrite Heq ; eexists...
    * apply IHpi...
      destruct l0 ; inversion Heq ; subst.
      right ; exists (l0,P)...
  + destruct (Permutation_Type_vs_cons_inv _ _ _ HP) as ((l2 & l3) & Heq).
    destruct l2 ; inversion Heq ; subst.
    assert (pi' := pi).
    apply bipos_top_surf with _ P Q (l2 ++ l3) in pi' ; [ | perm_Type_solve ].
    destruct pi' as [(N & l & l') Heq' Htop].
    apply (ex_r _ (pos P :: pos Q :: l2 ++ l3)) in pi ; [ | perm_Type_solve ].
    rewrite Heq' in pi.
    apply (ex_r _ (neg N :: pos P :: pos Q :: l ++ l')) in pi ; [ | perm_Type_solve ].
    eapply top_imp_top_surf_ps in Htop.
    * apply (ex_ps_r _ (neg N :: neg (wn P) :: pos Q :: l ++ l'))...
      -- apply polsequent_true.
         right ; eexists...
      -- transitivity (neg (wn P) :: pos Q :: l2 ++ l3) ;
           [ rewrite Heq' | ] ; perm_Type_solve.
    * apply (polsequent_neg_rem N).
      right ; exists (l0,Q).
      etransitivity ; [ | apply HP ].
      transitivity (neg (wn P) :: pos Q :: l2 ++ l3) ;
        [ rewrite Heq' | ] ; perm_Type_solve.
- apply wk_ps_r ; [ apply polsequent_true | ]...
  apply IHpi.
  eapply polsequent_neg_rem...
- apply co_ps_r ; [ apply polsequent_true | ]...
  apply IHpi.
  apply polsequent_neg_add...
Qed.

(** [llpol] with [top] rule constrained to at most one positive formula. *)
Inductive llpolt : list formula -> Type :=
| ax_rt : forall X, llpolt (neg (covar X) :: pos (var X) :: nil)
| ex_rt : forall l1 l2, llpolt l1 ->
               Permutation_Type l1 l2 -> llpolt l2
| one_rt : llpolt (pos one :: nil)
| bot_rt : forall l, llpolt l -> llpolt (neg bot :: l)
| tens_rt : forall P Q l1 l2,
               llpolt (pos P :: l1) -> llpolt (pos Q :: l2) ->
               llpolt (pos (tens P Q) :: l1 ++ l2)
| parr_rt : forall N M l,
               llpolt (neg N :: neg M :: l) ->
               llpolt (neg (parr N M) :: l)
| top_rt : forall l, polsequent l -> llpolt (neg top :: l)
| plus_rt1 : forall P Q l, llpolt (pos P :: l) ->
               llpolt (pos (aplus P Q) :: l)
| plus_rt2 : forall P Q l, llpolt (pos P :: l) ->
               llpolt (pos (aplus Q P) :: l)
| with_rt : forall N M l,
               llpolt (neg N :: l) -> llpolt (neg M :: l) ->
               llpolt (neg (awith N M) :: l)
| oc_rt : forall N l,
               llpolt (neg N :: map neg (map wn l)) ->
               llpolt (pos (oc N) :: map neg (map wn l))
| de_rt : forall P l,
               llpolt (pos P :: l) -> llpolt (neg (wn P) :: l)
| wk_rt : forall P l,
               llpolt l -> llpolt (neg (wn P) :: l)
| co_rt : forall P l,
               llpolt (neg (wn P) :: neg (wn P) :: l) ->
               llpolt (neg (wn P) :: l).

Instance llpolt_perm : Proper ((@Permutation_Type _) ==> Basics.arrow) llpolt.
Proof.
intros l1 l2 HP pi.
eapply ex_rt ; eassumption.
Qed.

(** For polarized sequents [llpol] corresponds to [top] rule with at most one positive formula. *)
Theorem llpol_llpolt : forall l, polsequent l -> llpol l -> llpolt l.
Proof with try eassumption ; try reflexivity.
intros l Hpol pi.
apply llpol_is_ll_polsequent in pi...
clear Hpol ; induction pi ; try (now constructor).
- eapply ex_rt...
- apply true_polsequent in i.
  apply top_rt.
  eapply polsequent_neg_rem...
Qed.

Theorem llpolt_llpol : forall l, llpolt l -> (polsequent l * llpol l).
Proof with try eassumption ; try reflexivity.
intros l pi.
induction pi ; split ;
  try (destruct IHpi as [Hpol pi']) ;
  try (destruct IHpi1 as [Hpol1 pi1']) ;
  try (destruct IHpi2 as [Hpol2 pi2']) ;
  try now constructor...
- right ; exists (covar X :: nil,var X) ; perm_Type_solve.
- destruct Hpol.
  + destruct s as [l0 H0] ; subst.
    symmetry in p.
    apply Permutation_Type_map_inv in p.
    destruct p as [l3 Heq HP] ; subst.
    left ; exists l3...
  + destruct s as ((l0 & P) & H0) ; subst.
    assert (HP := H0).
    apply Permutation_Type_vs_cons_inv in H0.
    destruct H0 as ((l3 & l4) & Heq) ; subst.
    symmetry in HP.
    apply Permutation_Type_cons_app_inv in HP.
    right ; exists (l0,P) ; perm_Type_solve.
- eapply ex_r...
- right ; exists (nil,one) ; perm_Type_solve.
- apply polsequent_neg_add...
- apply polsequent_pos_rem in Hpol1.
  destruct Hpol1 as [l1' Heq] ; subst.
  apply polsequent_pos_rem in Hpol2.
  destruct Hpol2 as [l2' Heq] ; subst.
  right ; exists (l1' ++ l2',tens P Q) ; perm_Type_solve.
- apply polsequent_neg_rem in Hpol.
  apply polsequent_neg_rem in Hpol.
  eapply polsequent_neg_add...
- eapply polsequent_neg_add...
- apply polsequent_pos_rem in Hpol.
  destruct Hpol as [l' Heq] ; subst.
  right ; exists (l',aplus P Q) ; perm_Type_solve.
- apply polsequent_pos_rem in Hpol.
  destruct Hpol as [l' Heq] ; subst.
  right ; exists (l',aplus Q P) ; perm_Type_solve.
- apply polsequent_neg_rem in Hpol1.
  eapply polsequent_neg_add...
- right ; exists (map wn l,oc N) ; perm_Type_solve.
- apply polsequent_pos_rem in Hpol.
  destruct Hpol as [l' Heq] ; subst.
  left ; exists (wn P :: l')...
- eapply polsequent_neg_add...
- eapply polsequent_neg_rem...
Qed.


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

(** * [Proper] instances for propositional connectives.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Require Import Coq.Classes.Morphisms.
Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.

Local Obligation Tactic := try solve [simpl_relation | firstorder auto].

(** Standard instances for [not], [iff] and [impl]. *)

(** Logical negation. *)

Program Instance not_impl_morphism :
  Proper (impl --> impl) not | 1.

Program Instance not_iff_morphism :
  Proper (iff ++> iff) not.

(** Logical conjunction. *)

Program Instance and_impl_morphism :
  Proper (impl ==> impl ==> impl) and | 1.

Program Instance and_iff_morphism :
  Proper (iff ==> iff ==> iff) and.

(** Logical disjunction. *)

Program Instance or_impl_morphism :
  Proper (impl ==> impl ==> impl) or | 1.

Program Instance or_iff_morphism :
  Proper (iff ==> iff ==> iff) or.

(** Logical implication [impl] is a morphism for logical equivalence. *)

Program Instance iff_iff_iff_impl_morphism : Proper (iff ==> iff ==> iff) impl.

(** Morphisms for quantifiers *)

Program Instance ex_iff_morphism {A : Type} : Proper (pointwise_relation A iff ==> iff) (@ex A).

Program Instance ex_impl_morphism {A : Type} :
  Proper (pointwise_relation A impl ==> impl) (@ex A) | 1.

Program Instance ex_flip_impl_morphism {A : Type} :
  Proper (pointwise_relation A (flip impl) ==> flip impl) (@ex A) | 1.

Program Instance all_iff_morphism {A : Type} :
  Proper (pointwise_relation A iff ==> iff) (@all A).

Program Instance all_impl_morphism {A : Type} :
  Proper (pointwise_relation A impl ==> impl) (@all A) | 1.

Program Instance all_flip_impl_morphism {A : Type} :
  Proper (pointwise_relation A (flip impl) ==> flip impl) (@all A) | 1.

(** Equivalent points are simultaneously accessible or not *)

Instance Acc_pt_morphism {A:Type}(E R : A->A->Prop)
 `(Equivalence _ E) `(Proper _ (E==>E==>iff) R) :
 Proper (E==>iff) (Acc R).
Proof.
 apply proper_sym_impl_iff; auto with *.
 intros x y EQ WF. apply Acc_intro; intros z Hz.
rewrite <- EQ in Hz. now apply Acc_inv with x.
Qed.

(** Equivalent relations have the same accessible points *)

Instance Acc_rel_morphism {A:Type} :
 Proper (relation_equivalence ==> Logic.eq ==> iff) (@Acc A).
Proof.
 apply proper_sym_impl_iff_2. red; now symmetry. red; now symmetry.
 intros R R' EQ a a' Ha WF. subst a'.
 induction WF as [x _ WF']. constructor.
 intros y Ryx. now apply WF', EQ.
Qed.

(** Equivalent relations are simultaneously well-founded or not *)

Instance well_founded_morphism {A : Type} :
 Proper (relation_equivalence ==> iff) (@well_founded A).
Proof.
 unfold well_founded. solve_proper.
Qed.


(** * Kripke Semantics *)

Require Export FOL.Deduction.

(** ** Kripke Models *)

Section Kripke.

  Context {domain : Type}.
  Variable eta : nat -> domain.

  Structure embedding (I J : interp domain eta) :=
    {
      Hf : forall b d, @i_f _ _ I b d = @i_f _ _ J b d ;
      He : @i_e _ _ I = @i_e _ _ J ;

      HP : forall c d, @i_P _ _ I c d -> @i_P _ _ J c d ;
      HQ : @i_Q _ _ I -> @i_Q _ _ J
    }.

  Lemma emb_refl (I : interp domain eta) :
    embedding I I.
  Proof.
    firstorder.
  Qed.

  Definition emb_trans (I J K : interp domain eta) :
    embedding I J -> embedding J K -> embedding I K.
  Proof.
    intros F F'. econstructor.
    - intros b d. rewrite (Hf F), (Hf F'). reflexivity.
    - now rewrite (He F), (He F').
    - intros c d. intros. now eapply (HP F'), (HP F).
    - intros. now eapply (HQ F'), (HQ F).
  Qed.

  Class kmodel :=
    {
      nodes : Type ;

      reachable : nodes -> nodes -> Prop ;
      reach_refl u : reachable u u ;
      reach_tran u v w : reachable u v -> reachable v w -> reachable u w ;

      world : nodes -> interp domain eta ;

      world_f : forall u v, reachable u v -> embedding (world u) (world v)
    }.

  Variable M : kmodel.
  Implicit Type b : logic.

  Fixpoint ksat b u (rho : var -> domain) (phi : form b) : Prop :=
    match phi with
    | Pr t1 t2 => @i_P _ _ (world u) (@eval _ _ (world u) rho t1) (@eval _ _ (world u) rho t2)
    | Q => @i_Q _ _ (world u)
    | Fal => False
    | Impl phi psi => forall v, reachable u v -> ksat v rho phi -> ksat v rho psi
    | All n phi => forall v, reachable u v -> forall j : domain, ksat v (rho [[ n := j ]]) phi
    end.

  Global Arguments ksat {_} _ _ _.

  Notation "rho  '⊨(' u ')'  phi" := (ksat u rho phi) (at level 20).
  Notation "rho  '⊫(' u ')'  A" := (forall phi, phi el A -> rho ⊨(u) phi) (at level 20).

  Lemma eval_invar u v :
    reachable u v -> forall rho t, @eval _ _ (world u) rho t = @eval _ _ (world v)rho t.
  Proof.
    intros H rho t. induction t; cbn; try congruence.
    - now rewrite IHt, (Hf (world_f H)).
    - now rewrite (He (world_f H)).
  Qed.

  Lemma ksat_mon b (u : nodes) (rho : var -> domain) (phi : form b) :
    forall v (H : reachable u v), ksat u rho phi -> ksat v rho phi.
  Proof.
    revert rho. induction phi; intros rho v H; cbn.
    - intros. rewrite <- !(eval_invar H). now eapply (world_f H).
    - intros. now eapply (world_f H).
    - eauto.
    - intros H1 K H2 H3. apply H1; eauto. eapply reach_tran; eauto.
    - intros H1 K H2 k. apply (H1 K (reach_tran H H2) k).
  Qed.

  Lemma ksat_iff b u rho phi :
    ksat u rho phi <-> forall v (H : reachable u v), ksat v rho phi.
  Proof.
    split.
    - intros H1 v H2. eapply ksat_mon; eauto.
    - intros H. apply H. eapply reach_refl.
  Qed.

  Notation sem_imp v rho A phi :=
    ((forall psi, psi el A -> ksat v rho psi) -> ksat v rho phi).

  Lemma impl_ksat {b} u A rho (phi : form b) :
    ksat u rho (A ==> phi) <-> (forall v, reachable u v -> sem_imp v rho A phi).
  Proof.
    cbn. revert u rho. induction A; cbn; intros u rho.
    - intuition.
      + eapply ksat_mon; eauto.
      + apply H. eapply reach_refl. tauto.
    - split; intros H v H1 H2.
      + specialize (H v H1). rewrite IHA in H.
        assert (H' : ksat v rho a) by (now apply H2; now left).
        apply (H H' v (reach_refl v)).
        intros psi H0. apply H2. now right.
      + apply IHA. intros w H3 H4.
        apply H. eapply reach_tran; eauto. intros psi [-> |H'].
        * eapply ksat_mon; eauto.
        * now apply H4.
  Qed.

  Lemma impl_ksat' {b} u A rho (phi : form b) :
    ksat u rho (A ==> phi) -> (forall v, reachable u v -> sem_imp v rho A phi).
  Proof.
    apply impl_ksat.
  Qed.

End Kripke.

Arguments ksat {_} _ _ {_} _ _ _, {_ _} _ {_} _ _ _.

(* Notation "rho '⊫(' u ')'  A" := ( forall phi, phi el A -> ksat u rho phi) (at level 20). *)
Notation "rho '⊩(' u , M , eta ')' phi" := (@ksat _ eta M _ u rho phi) (at level 20).

(** ** Connection to Tarski Semantics *)

Instance interp_kripke {domain eta} (I : interp domain eta) : kmodel  eta :=
  {| nodes := unit ; reachable u v := True |}.
Proof.
  all: try abstract tauto.
  intros. apply emb_refl.
Defined.

Lemma kripke_tarski domain eta (b : logic) (I : interp domain eta) rho phi :
  rho ⊨ phi <-> rho ⊩(tt, interp_kripke I, _) phi.
Proof.
  revert rho. induction phi; intros rho.
  - tauto.
  - tauto.
  - tauto.
  - split; intros H. cbn in *.
    + intros [] [] H'. apply IHphi2, H,  IHphi1, H'.
    + intros H'. apply IHphi2, (H tt Logic.I), IHphi1, H'.
  - split; intros H; cbn in *.
    + intros [] [] i. apply IHphi, H.
    + intros i. apply IHphi, (H tt Logic.I).
Qed.

Definition kvalid b (phi : form b) :=
  forall domain eta (M : @kmodel domain eta) u rho, rho ⊩(u,M,eta) phi.

Definition ksatis b (phi : form b) :=
  exists domain eta (M : @kmodel domain eta) u rho, ksat eta M u rho phi.

Lemma kvalid_valid b (phi : form b) :
  kvalid phi -> valid phi.
Proof.
  intros H domain I eta rho. eapply kripke_tarski, H.
Qed.

Lemma ksatis_satis b (phi : form b) :
  satis phi -> ksatis phi.
Proof.
  intros (domain & eta & I & rho & ?). eapply kripke_tarski in H.
  now exists domain, eta, (interp_kripke I), tt,  rho.
Qed.

(** ** Soundness **)

Hint Resolve reach_refl.

Definition kcast domain (eta eta' : nat -> domain) (M : kmodel eta) : kmodel eta'.
Proof.
  unshelve econstructor.
  - exact (@nodes _ _ M).
  - exact (@reachable _ _ M).
  - intros. eapply cast. eapply (@world _ _ M). exact X.
  - eauto.
  - destruct M; eauto.
  - destruct M. abstract (
    intros; cbn; destruct (world_f0 u v H), (world0 u), (world0 v); cbn; econstructor; eauto).
Defined.

Notation "! M" := (kcast _ M) (at level 10).

Lemma ksat_ext_p dom b (phi : form b) rho rho' eta eta' (M : @kmodel dom eta ) u :
  (forall v, rho v = rho' v) ->
  (forall p, p el consts phi -> eta p = eta' p) ->
  rho ⊩(u,M,eta) phi <->
  rho' ⊩(u, !M, eta') phi.
Proof.
  intros. revert u rho rho' H; induction phi; cbn in *; intros.
  - destruct (world u). erewrite eval_ext_p with (eta' := eta').
    erewrite eval_ext_p with (eta := eta).
    cbn. reflexivity. all: cbn in *; firstorder.
  - destruct (world u); firstorder.
  - firstorder.
  - split; intros.
    + eapply IHphi2. 3: eapply H1. all: eauto.
      eapply IHphi1; try eassumption; eauto.
    + eapply IHphi2. 3: eapply H1. all: eauto.
      eapply IHphi1; try eassumption; eauto.
  - firstorder; eapply IHphi. 6:eapply H1. 3:eapply H1. all:firstorder. all:decs.
Qed.

Lemma ksat_ext dom b (phi : form b) rho rho' eta (M : @kmodel dom eta ) u :
  rho ⊩(u,M,eta) phi -> (forall v, rho v = rho' v) ->  rho' ⊩(u,M,eta) phi.
Proof.
  intros H1 H2. erewrite ksat_ext_p in *; eauto.
Qed.

Lemma subst_ksat dom b eta rho (M : @kmodel dom eta ) u (phi : form b) x t :
  vars_t t = [] ->
  rho ⊩(u,M,eta) (subst x t phi) <-> rho[[x:=eval (I:=world u) rho t]] ⊩(u,M,eta) phi.
Proof.
  intros Hy. revert u rho.
  induction phi; intros u rho; cbn in *; try rewrite fresh_app in *.
  - now rewrite !subst_eval.
  - reflexivity.
  - reflexivity.
  - split; intros H w H1 H2.
    + erewrite (eval_invar H1). apply IHphi2; eauto.
      apply H, IHphi1; eauto. erewrite <- (eval_invar H1). eassumption.
    + apply IHphi2; eauto. rewrite <- (eval_invar H1).
      apply H. eassumption. rewrite (eval_invar H1). apply IHphi1; eauto.
  - cbn. split.
    + intros H v H1 j. destruct Dec as [->|H'].
      * specialize (H v H1 j). apply (ksat_ext H). intros z. decs.
      * specialize (H v H1 j). apply IHphi in H; eauto.
        rewrite eval_empty with (rho':=rho) in H; trivial.
        apply (ksat_ext H). intros. decs. now rewrite (eval_invar H1).
    + intros H v H1 j. destruct Dec as [->|H'].
      * specialize (H v H1 j). apply (ksat_ext H). intros z. decs.
      * specialize (H v H1 j). apply IHphi; eauto.
        rewrite eval_empty with (rho':=rho); trivial.
        apply (ksat_ext H). intros. decs. now rewrite (eval_invar H1).
Qed.

Lemma substconst_ksat b dom eta rho (phi : form b) x a d (M : @kmodel dom eta) u :
  fresh a (consts phi) ->
  rho ⊩(u, kcast (eta [[a := d]]) M, _) (subst x (P a) phi) <->
  rho [[ x := d ]] ⊩(u,M,eta) phi.
Proof.
  intros H. rewrite subst_ksat; trivial.
  symmetry. eapply ksat_ext_p; intros n; repeat decs.
Qed.

(* Arguments ksat {_ _} _ {_} _ _ _. *)

Lemma ksoundness' {b} A (phi : form b) :
  A ⊢I phi -> kvalid (A ==> phi).
Proof.
  remember intu as s.
  induction 1; intros domain eta M u rho; eapply impl_ksat; intros; subst.
  - eauto.
  - intros ? ? ?. apply (impl_ksat' (IHprv eq_refl domain eta M u rho) ). eauto using reach_tran.
    intros ? [-> | ]; eauto. eapply ksat_mon. eauto using reach_tran. eauto.
  - pose proof (impl_ksat' (IHprv1 eq_refl domain eta M u rho)). specialize (H3 v H1).  cbn in H3.
    eapply H3; eauto. eapply (impl_ksat' (IHprv2 eq_refl domain eta M u rho)); eauto.
  - intros w H3 d. specialize (IHprv eq_refl domain _ (kcast (eta [[y := d]]) M) w rho). rewrite impl_ksat in IHprv.
    specialize (IHprv w (reach_refl _)).
    rewrite <- substconst_ksat. apply IHprv. 2: firstorder.
    intros. specialize (H2 _ H4). eapply ksat_iff in H2; eauto.
    rewrite <- ksat_ext_p; eauto. intros. decs. destruct H; firstorder.
    eapply in_app_iff. right. eapply in_flat_map. eauto.
  - eapply subst_ksat. rewrite H; eauto. pose proof (impl_ksat' (IHprv eq_refl domain eta M u rho)). cbn in H3.
    specialize (H3 v H1 H2 v (reach_refl _)). eapply H3.
  - specialize (IHprv eq_refl domain eta M v rho).
    eapply impl_ksat in IHprv as []; eauto.
  - inv Heqs.
Qed.

Theorem ksoundness {b} (phi : form b) :
  [] ⊢I phi -> valid phi.
Proof.
  apply soundness'.
Qed.


From Undecidability.L Require Import LTactics Datatypes.Lists Datatypes.LNat Datatypes.LBool.
From Undecidability.TM Require TM.

From Undecidability.TM Require Import TM_facts SizeBounds.

From Undecidability.L.Complexity  Require Import UpToCNary.

From Undecidability.L.AbstractMachines Require Import FlatPro.Programs.

Unset Printing Coercions.

From Undecidability.TM.L Require Alphabets.

From Coq Require Import Lia Ring Arith.

From Undecidability Require Import TM.Code.List.Concat_Repeat.

Definition enc_bool_perElem (b:bool) := [lamT;lamT;varT 0;lamT; lamT; varT (if b then 1 else 0); retT; retT;appT].
Definition enc_bool_nil := [lamT; lamT; varT 1; retT; retT].
Definition enc_bool_closing :=  [appT; retT; retT].

Lemma enc_bool_explicit (bs : list bool):
  compile (enc bs) = flat_map enc_bool_perElem bs ++ enc_bool_nil ++ concat (repeat enc_bool_closing (length bs)).
Proof.
  repeat unfold enc;cbn.
  induction bs as [ | b bs]. reflexivity.
  cbn - [concat repeat]. rewrite IHbs. replace (S (| bs |)) with (|bs|+1) by nia.
  destruct b;cbn - [concat repeat]. all:repeat (autorewrite with list; cbn - [concat repeat]). all:repeat f_equal.
  all:rewrite repeat_add_app,concat_app. all:easy.
Qed.

Lemma enc_boollist_helper bs :
 flat_map enc_bool_perElem bs ++ enc_bool_nil
 = [lamT;lamT;varT (match bs with [] => 1 | _ => 0 end)]++ skipn 3 (flat_map enc_bool_perElem bs ++ enc_bool_nil).
 Proof.
   destruct bs;reflexivity.
 Qed.

Lemma enc_bool_perElem_size :( fun b => Code.size (enc_bool_perElem b)) <=c (fun _ => 1).
Proof.
  eexists. intros []. all:cbv - [mult]. now rewrite Nat.mul_1_r. easy.
Qed.

Lemma boollist_size :( fun (bs:list bool) => Code.size bs) <=c (fun bs => length bs + 1).
Proof.
  eexists. intros bs. rewrite size_list. erewrite (MoreBase.sumn_map_le_pointwise (f2:=fun _ => _)).
  2:{ intros [] ?;cbv. all:reflexivity. } setoid_rewrite MoreList.sumn_map_c. instantiate (1:=2). nia.
Qed.

Lemma boollist_length: ( fun (bs:list bool) => length bs) <=c Code.size.
Proof.
  eexists. intros bs. rewrite size_list. erewrite <- (MoreBase.sumn_map_le_pointwise (f1:=fun _ => _)).
  2:{ intros [] ?;cbv. all:reflexivity. } setoid_rewrite MoreList.sumn_map_c. instantiate (1:=2). nia.
Qed.

Arguments enc_bool_perElem : simpl never.
Arguments enc_bool_nil : simpl never.
Arguments enc_bool_closing : simpl never.


Require Import Utf8 Basics Setoid FunctionalExtensionality List Ensembles.

Import ListNotations.

Import EqNotations.

Add LoadPath "Category".
Require Import Category Functor.

(*** Natural Transformations *)

Class NatTrans `{C : Category} `{D : Category}
  Fo Fh Go Gh (F : Functor C D Fo Fh) (G : Functor C D Go Gh)
  (alpha : forall c, (Fo c) --> (Go c)) := {
  naturality : forall c c' (f : c --> c'),
    ((alpha c') • (F [[f]])) = ((G [[f]]) • (alpha c));
}.

(* there is two ways of composing nat trans and functors to obtain a new nat. trans *)
(*
Instance idTrans {C B: Category} (F : Functor C B) : NatTrans F F := {
  component := (fun c => id);
}.
Proof.
  intros c c' f. rewrite idLeft. rewrite idRight. reflexivity.
Defined.

(* todo compose natural transformations *)

Instance natTransFunctor {A B C} {F G : Functor A B}
  (e : NatTrans F G) (H : Functor C A) : NatTrans (F * H) (G * H) := {
  component := (fun c => e (H c));
}.
Proof.
  intros c c' f. simpl. apply naturality.
Qed.

Instance functorNatTrans {A B C} {F G: Functor A B}
  (e : NatTrans F G) (H : Functor B C) : NatTrans (H * F) (H * G) := {
  component := (fun c => F_Hom H (e c));
}.
Proof.
  intros c c' f . simpl.
  rewrite <- (@compProp B C H (F c) (F c') (G c')).
  rewrite <- (@compProp B C H (F c) (G c) (G c')).
  rewrite naturality. reflexivity.
Qed.*)

(** EXAMPLES **)

Fixpoint flatten A (t : tree A) : list A :=
  match t with
    | leaf a => [a]
    | bin t1 t2 => (flatten A t1) ++ (flatten A t2)
  end.

Instance Natural_Flatten : NatTrans _ _ _ _ Tree_Functor List_Functor flatten.
  constructor. intros A B h. extensionality t.
  induction t.
  - compute. reflexivity.
  - autounfold in *. simpl. rewrite IHt1, IHt2. rewrite map_app. auto.
Defined.

Instance Natural_Singleton : NatTrans _ _ _ _ _ P_Functor (fun A => Singleton A).
  constructor. intros A B f. autounfold. extensionality a.
  apply Extensionality_Ensembles. split; intros b H.
  + compute in *. inversion H. exists a. split; auto. constructor.
  + compute in *. destruct H as [a' [H1 H2] ]. inversion H1. subst. constructor.
Defined.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

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

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

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

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

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_lib.
Require Export sequents_tacs.
Require Export sequents_equality.
Require Export per_props_uni.
Require Export per_props_halts.

Definition rule_universe_equality_concl {o} (H : @bhyps o) i j : baresequent :=
  mk_baresequent H (mk_conclax (mk_member (mk_uni i) (mk_uni j))).

(*
   H |- Type(i) = Type(i) in Type(j)

     By universeEquality (i < j)
 *)
Definition rule_universe_equality {o}
           (H : @bhyps o)
           (i j : nat) :=
  mk_rule
    (rule_universe_equality_concl H i j)
    []
    [].

Lemma rule_universe_equality_true3 {o} :
  forall lib (H : @bhyps o) (i j : nat),
    i < j -> rule_true3 lib (rule_universe_equality H i j).
Proof.
  intros.
  unfold rule_universe_equality, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs hyps.

  (* We prove the well-formedness of things *)
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent (H) ||- (mk_conclax (mk_member (mk_uni i) (mk_uni j)))) as wfc.
  { unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  pose proof (teq_and_member_if_member lib (mk_uni j) (mk_uni i) s1 s2 H wT wt ct ct0 cT cT0) as q.
  rw <- @member_member_iff.
  lsubst_tac.
  apply q; auto.
  { apply tequality_mkc_uni. }
  clear dependent s1; clear dependent s2.
  introv hf sim.
  lsubst_tac.
  apply uni_in_uni; auto.
Qed.

Lemma rule_universe_equality_true_ext_lib {o} :
  forall lib (H : @bhyps o) (i j : nat),
    i < j -> rule_true_ext_lib lib (rule_universe_equality H i j).
Proof.
  introv ltij.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_universe_equality_true3; auto.
Qed.

Definition rule_cumulativity_concl {o} (H : @bhyps o) T j :=
  mk_baresequent H (mk_conclax (mk_member T (mk_uni j))).

Definition rule_cumulativity_hyp {o} (H : @bhyps o) T i e :=
  mk_baresequent H (mk_concl (mk_member T (mk_uni i)) e).

(*
   H |- T in Type(j)

     By cumulativity (i < j)

     H |- T in Type(i)
 *)
Definition rule_cumulativity {o}
           (H : @bhyps o)
           (T e : NTerm)
           (i j : nat) :=
  mk_rule
    (rule_cumulativity_concl H T j)
    [ rule_cumulativity_hyp H T i e ]
    [].

Lemma rule_cumulativity_true3 {o} :
  forall lib (H : @bhyps o) T e (i j : nat),
    i <= j -> rule_true3 lib (rule_cumulativity H T e i j).
Proof.
  intros.
  unfold rule_cumulativity, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp  as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent (H) ||- (mk_conclax (mk_member T (mk_uni j)))) as wfc.
  { clear hyp1.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp.
    introv xx; allrw in_app_iff; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  rw <- @member_member_iff.
  pose proof (teq_and_member_if_member lib (mk_uni j) T s1 s2 H wT wt ct0 ct1 cT cT0) as q.
  lsubst_tac.
  apply q; auto.
  { apply tequality_mkc_uni. }
  clear dependent s1; clear dependent s2.

  introv hf sim.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as q; clear hyp1; exrepnd.
  lsubst_tac.
  apply member_if_inhabited in q1.

  apply tequality_mkc_member in q0; repnd; clear q2.
  dimp q0. eapply cumulativity;eauto.

Qed.

Lemma rule_cumulativity_true_ext_lib {o} :
  forall lib (H : @bhyps o) T e (i j : nat),
    i <= j -> rule_true_ext_lib lib (rule_cumulativity H T e i j).
Proof.
  introv ltij.
  apply rule_true3_implies_rule_true_ext_lib.
  introv.
  apply rule_cumulativity_true3; auto.
Qed.

Lemma rule_cumulativity_wf2 {o} :
  forall (H : @bhyps o) T e (i j : nat),
    wf_rule2 (rule_cumulativity H T e i j).
Proof.
  introv wf k.
  allsimpl; repndors; subst; tcsp;
    allunfold @wf_bseq; repnd; allsimpl; wfseq.
Qed.

(*
   H |- halts(t)

     By callbyvalueType

     H |- t in Type(i)
 *)
Definition rule_callbyvalue_type {o}
           (H : @bhyps o)
           (t : NTerm)
           (i : nat) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_halts t)))
    [
      mk_baresequent H (mk_conclax (mk_member t (mk_uni i)))
    ]
    [].

Lemma rule_callbyvalue_type_true3 {o} :
  forall lib (H : @bhyps o) t i,
    rule_true3 lib (rule_callbyvalue_type H t i).
Proof.
  intros.
  unfold rule_callbyvalue_type, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp  as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  { clear hyp1.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as h; clear hyp1; exrepnd.
  lsubst_tac.

  rw <- @member_member_iff in h1.
  repeat (rw <- @fold_mkc_member in h0).
  apply equality_commutes in h0; auto.
  clear h1.
  apply equality_in_uni in h0.
  applydup @tequality_refl in h0.
  apply tequality_sym in h0.
  apply tequality_refl in h0.
  apply types_converge in h0.
  apply types_converge in h1.
  spcast.

  rw @equality_in_mkc_halts_ax.
  eapply teq_and_eq_if_halts; eauto; spcast; auto.
Qed.


Require Export P05.

Lemma constfold_0plus_sound:
  ctrans_sound constfold_0plus.
Proof.
  unfold ctrans_sound. intros.
  unfold cequiv. intros.
  unfold constfold_0plus.
  assert (c / st || st' <-> (fold_constants_com c) / st || st').
  apply fold_constants_com_sound.
  rewrite H.
  apply optimize_0plus_com_sound.
  Qed.