Require Import Arith.
Require Import List.
Require Import Relations.
Require Import Wellfounded.
Require Import list_util.

Hint Resolve incl_refl lt_le_weak Nat.le_max_l Nat.le_max_r le_not_lt lt_not_le.

(* LQ *)
Inductive Term : Set :=
|Var: nat -> Term
|Const: nat -> Term
|Func: nat -> list Term -> Term
.

Inductive Formula : Set :=
|Pred: nat -> list Term -> Formula
|Neg: Formula -> Formula
|Imp: Formula -> Formula -> Formula
|Any: nat -> Formula -> Formula
.

Definition LQand (f g:Formula) := Neg (Imp f (Neg g)).
Definition LQor (f g:Formula) := Imp (Neg f) g.
Definition Ex v f := Neg (Any v (Neg f)).

(* Declare Scope LQ_scope. *)
Notation "! f" := (Neg f) (at level 80, no associativity) : LQ_scope.
Notation "f ==> g" := (Imp f g) (at level 83, right associativity) : LQ_scope.
Notation "f &^ g" := (LQand f g) (at level 81, left associativity) : LQ_scope.
Notation "f |^ g" := (LQor f g) (at level 82, left associativity) : LQ_scope.

Open Scope LQ_scope.

Inductive FreeVarTerm (v:nat) : Term -> Prop :=
|FVT_var: FreeVarTerm v (Var v)
|FVT_func: forall i t l, FreeVarTerm v t -> In t l -> FreeVarTerm v (Func i l)
.
Inductive FreeVar (v:nat) : Formula -> Prop :=
|FV_pred: forall i t l, FreeVarTerm v t -> In t l -> FreeVar v (Pred i l)
|FV_Neg: forall f, FreeVar v f -> FreeVar v (!f)
|FV_Imp1: forall f g, FreeVar v f -> FreeVar v (f==>g)
|FV_Imp2: forall f g, FreeVar v g -> FreeVar v (f==>g)
|FV_Any: forall i f, i<>v -> FreeVar v f -> FreeVar v (Any i f)
.
Inductive VarIn (v:nat) : Formula -> Prop :=
|VI_pred: forall i t l, FreeVarTerm v t -> In t l -> VarIn v (Pred i l)
|VI_Neg: forall f, VarIn v f -> VarIn v (!f)
|VI_Imp1: forall f g, VarIn v f -> VarIn v (f==>g)
|VI_Imp2: forall f g, VarIn v g -> VarIn v (f==>g)
|VI_Any1: forall i f, VarIn v f -> VarIn v (Any i f)
|VI_Any2: forall f, VarIn v (Any v f)
.

Inductive ConstInTerm (c:nat) : Term -> Prop :=
|CIT_const: ConstInTerm c (Const c)
|CIT_func: forall i t l, ConstInTerm c t -> In t l -> ConstInTerm c (Func i l)
.

Inductive ConstIn (c:nat) : Formula -> Prop :=
|CI_pred: forall i t l, ConstInTerm c t -> In t l -> ConstIn c (Pred i l)
|CI_Neg: forall f, ConstIn c f -> ConstIn c (!f)
|CI_Imp1: forall f g, ConstIn c f -> ConstIn c (f==>g)
|CI_Imp2: forall f g, ConstIn c g -> ConstIn c (f==>g)
|CI_Any: forall n f, ConstIn c f -> ConstIn c (Any n f)
.

Inductive SubTerm (v:nat) (t:Term) : relation Term :=
|ST_var1: SubTerm v t (Var v) t
|ST_var2: forall i, i<>v -> SubTerm v t (Var i) (Var i)
|ST_const: forall i, SubTerm v t (Const i) (Const i)
|ST_func1: forall i, SubTerm v t (Func i nil) (Func i nil)
|ST_func2: forall i f g l m, SubTerm v t (Func i l) (Func i m) -> SubTerm v t f g -> SubTerm v t (Func i (f::l)) (Func i (g::m))
.

Inductive Sub (v:nat) (t:Term) : relation Formula :=
|Sub_pred1: forall i, Sub v t (Pred i nil) (Pred i nil)
|Sub_pred2: forall i f g l m, SubTerm v t f g -> Sub v t (Pred i l) (Pred i m) -> Sub v t (Pred i (f::l)) (Pred i (g::m))
|Sub_neg: forall f g, Sub v t f g -> Sub v t (!f) (!g)
|Sub_imp: forall f1 f2 g1 g2, Sub v t f1 g1 -> Sub v t f2 g2 -> Sub v t (f1==>f2) (g1==>g2)
|Sub_any1: forall f, Sub v t (Any v f) (Any v f)
|Sub_any2: forall i f g, i<>v -> Sub v t f g -> Sub v t (Any i f) (Any i g)
.

Inductive BoundByRep (x y:nat) : Formula -> Prop :=
|BBR_neg: forall f, BoundByRep x y f -> BoundByRep x y (!f)
|BBR_imp1: forall f g, BoundByRep x y f -> BoundByRep x y (f==>g)
|BBR_imp2: forall f g, BoundByRep x y g -> BoundByRep x y (f==>g)
|BBR_any1: forall f, y<>x -> FreeVar x f -> BoundByRep x y (Any y f)
|BBR_any2: forall i f, i<>x -> BoundByRep x y f -> BoundByRep x y (Any i f)
.

Inductive TFFSub (v:nat) (t:Term) : relation Formula := TFFSub_intro: forall f g, Sub v t f g -> (forall i, FreeVarTerm i t -> ~BoundByRep v i f) -> TFFSub v t f g.

Inductive LQAxiom: Formula -> Prop :=
|LQA1 : forall f g, LQAxiom (f==>g==>f)
|LQA2 : forall f g h, LQAxiom ((f==>g==>h)==>(f==>g)==>f==>h)
|LQA3 : forall f g, LQAxiom ((!f==>!g)==>g==>f)
|LQA4 : forall f v t g, TFFSub v t f g -> LQAxiom (Any v f ==> g)
|LQA5 : forall v f g, ~FreeVar v f -> LQAxiom (Any v (f==>g) ==> f ==> Any v g)
.

Inductive LQTheorem : Formula -> Prop:=
|LQAx: forall f, LQAxiom f -> LQTheorem f
|LQMp: forall f g, LQTheorem (f==>g) -> LQTheorem f -> LQTheorem g
|LQUg: forall v f, LQTheorem f -> LQTheorem (Any v f)
.

Inductive LQInf (pre:list Formula): Formula -> Prop :=
|LQIAx: forall f, LQAxiom f -> LQInf pre f
|LQIPre: forall f, In f pre -> LQInf pre f
|LQIMp: forall f g p1 p2, incl p1 pre -> incl p2 pre -> LQInf p1 (f==>g) -> LQInf p2 f -> LQInf pre g
|LQIUg: forall v f, (forall p, In p pre -> ~FreeVar v p) -> LQInf pre f -> LQInf pre (Any v f)
.
Hint Constructors FreeVarTerm FreeVar VarIn ConstInTerm ConstIn SubTerm Sub BoundByRep TFFSub LQAxiom LQTheorem LQInf.

Fixpoint termDepth (t:Term) : nat := match t with |Var _ => 0 |Const _ => 0 |Func _ l => S (fold_right (fun t x=>max x (termDepth t)) 0 l) end.
Definition Term_eq_dec: forall t u:Term, {t=u}+{t<>u}. intros t. apply (Fix (well_founded_ltof Term termDepth)) with (P:=fun t=>forall u, {t=u}+{t<>u}). clear t. intros t IH u. destruct t; destruct u; try (right;discriminate). destruct (nat_eq_dec n n0); [subst n0; left|right]; auto. contradict n1; inversion n1; auto. destruct (nat_eq_dec n n0); [subst n0; left|right]; auto. contradict n1; inversion n1; auto. destruct (nat_eq_dec n n0); [subst n0|right]; auto. revert l0. induction l; intros. destruct l0; [left|right]; auto. intros C; inversion C. destruct l0. right; intros C; inversion C. destruct (IH a) with (u:=t). unfold ltof. simpl. apply le_n_S. apply Nat.le_max_r. subst t. destruct IHl with (l0:=l0). intros. apply IH. unfold ltof. unfold ltof in H. apply lt_le_trans with (termDepth (Func n l)); auto. simpl. apply le_n_S. apply Nat.le_max_l. left. inversion e; auto. right. contradict n0. inversion n0; auto. right. contradict n0. inversion n0; auto. contradict n1. inversion n1; auto. Defined.
Definition Formula_eq_dec: forall f g:Formula, {f=g}+{f<>g}. induction f; destruct g; try (right; discriminate). destruct (nat_eq_dec n n0). subst n0. destruct (list_eq_dec Term_eq_dec l l0). subst l0; left; auto. right. contradict n0. inversion n0; auto. right. contradict n1; inversion n1; auto. destruct (IHf g); [subst g;left|right]; auto. contradict n; inversion n; auto. destruct (IHf1 g1); [subst g1; destruct (IHf2 g2); [subst g2; left|right] |right]; auto; contradict n; inversion n; auto. destruct (nat_eq_dec n n0); [subst n0|right]. destruct (IHf g); [subst g; left|right]; auto. contradict n0; inversion n0; auto. contradict n1; inversion n1; auto. Defined.
Definition freeVarsTerm: forall t, {l| forall v, In v l <-> FreeVarTerm v t}. apply (Fix (well_founded_ltof Term termDepth)). intros t IH. destruct t. exists (n::nil). intros; split; intros. destruct H. subst n; auto. destruct H. inversion H; auto. exists nil. intros; split; intros. destruct H. inversion H.
  induction l. exists nil. intros; split; intros. destruct H. inversion H. destruct H3. destruct IHl as [vl H]. intros. apply IH. unfold ltof. unfold ltof in H. apply lt_le_trans with (termDepth (Func n l)); auto. simpl. apply le_n_S. apply Nat.le_max_l.
  destruct (IH a) as [al H0]. unfold ltof. simpl. apply le_n_S. apply Nat.le_max_r. exists (al++vl). intros; split; intros. apply in_app_or in H1. destruct H1. apply FVT_func with a; auto. apply H0; auto. apply H in H1. inversion H1. subst i l0. apply FVT_func with t; auto. apply in_or_app. inversion H1. subst i l0. destruct H5. subst t; left; apply H0; auto. right; apply H. apply FVT_func with t; auto. Defined.
Definition freeVars: forall f, {l| forall v, In v l <-> FreeVar v f}. induction f. exists (flat_map (fun t=> let (vl,_) := freeVarsTerm t in vl) l). intros; split; intros. apply in_flat_map in H. destruct H as [t [H H0]]. destruct (freeVarsTerm t) as [vl H1]. apply FV_pred with t; auto. apply H1; auto. inversion H. subst i l0. apply in_flat_map. exists t. split; auto. destruct (freeVarsTerm t) as [vl H0]. apply H0; auto.
  destruct IHf as [l H]. exists l; intros; split; intros. apply H in H0; auto. inversion H0. apply H; auto. destruct IHf1 as [l1 H]. destruct IHf2 as [l2 H0]. exists (l1++l2). intros; split; intros. apply in_app_or in H1. destruct H1. apply H in H1; auto. apply H0 in H1; auto. apply in_or_app. inversion H1. apply H in H3; auto. apply H0 in H3; auto. destruct IHf as [l H]. exists (remove nat_eq_dec n l). intros; split; intros. destruct (nat_eq_dec n v). subst n. contradict H0. apply remove_In. apply FV_Any; auto. apply H. apply remove_In2 in H0; auto. inversion H0. apply H in H4. apply in_in_remove; auto. Defined.
Definition varsIn: forall f, {l| forall v, In v l <-> VarIn v f}. induction f. exists (flat_map (fun t=> let (vl,_) := freeVarsTerm t in vl) l). intros; split; intros. apply in_flat_map in H. destruct H as [t [H H0]]. destruct (freeVarsTerm t) as [vl H1]. apply VI_pred with t; auto. apply H1; auto. inversion H. subst i l0. apply in_flat_map. exists t. split; auto. destruct (freeVarsTerm t) as [vl H0]. apply H0; auto.
  destruct IHf as [l H]. exists l; intros; split; intros. apply H in H0; auto. inversion H0. apply H; auto. destruct IHf1 as [l1 H]. destruct IHf2 as [l2 H0]. exists (l1++l2). intros; split; intros. apply in_app_or in H1. destruct H1. apply H in H1; auto. apply H0 in H1; auto. apply in_or_app. inversion H1. apply H in H3; auto. apply H0 in H3; auto. destruct IHf as [l H]. exists (n::l). intros; split; intros. destruct H0. subst n; auto. apply H in H0; auto. inversion H0; auto. right. apply H; auto. Defined.

Definition constsInTerm: forall t, {l|forall c, In c l <-> ConstInTerm c t}. apply (Fix (well_founded_ltof Term termDepth)). intros t IH. destruct t. exists nil. intros; split; intros. destruct H. inversion H. exists (n::nil). intros; split; intros. destruct H. subst n; auto. destruct H. inversion H; auto. induction l. exists nil. intros; split; intros. destruct H. inversion H. destruct H3. destruct IHl as [m H]. intros. apply IH. unfold ltof. unfold ltof in H. apply lt_le_trans with (termDepth (Func n l)); auto. simpl. apply le_n_S. apply Nat.le_max_l. destruct (IH a) as [o H0]. unfold ltof. simpl. apply le_n_S. apply Nat.le_max_r. exists (o++m). intros; split; intros. apply in_app_or in H1. destruct H1. apply H0 in H1; auto. apply CIT_func with a; auto. apply H in H1. inversion H1. apply CIT_func with t; auto. apply in_or_app. inversion H1. subst i l0. destruct H5. subst a. apply H0 in H4; auto. right. apply H. apply CIT_func with t; auto. Defined.
Definition constsIn: forall f, {l|forall c, In c l <-> ConstIn c f}. induction f. exists (flat_map (fun t=>let (m,_):= constsInTerm t in m) l). intros; split; intros. apply in_flat_map in H. destruct H as [t [H H0]]. destruct (constsInTerm t) as [m H1]. apply H1 in H0. apply CI_pred with t; auto. apply in_flat_map. inversion H. exists t. split; auto. destruct (constsInTerm t) as [m H4]. apply H4; auto. destruct IHf as [l H]. exists l. intros; split; intros. apply H in H0; auto. apply H; inversion H0; auto. destruct IHf1 as [l1 H1]. destruct IHf2 as [l2 H2]. exists (l1++l2). intros; split; intros. apply in_app_or in H. destruct H; [apply H1 in H|apply H2 in H]; auto. apply in_or_app. inversion H. left; apply H1; auto. right; apply H2; auto. destruct IHf as [l H]. exists l. intros; split; intros. apply H in H0; auto. inversion H0. apply H; auto. Defined.
Definition subTerm: forall v t u, {s|SubTerm v t u s & forall s', SubTerm v t u s' -> s'=s}. intros v t. apply (Fix (well_founded_ltof Term termDepth)). intros u IH. destruct u. destruct (nat_eq_dec n v). subst n. exists t; auto. intros. inversion H; auto. contradict H1; auto. exists (Var n); auto. intros. inversion H; [contradict n0|]; auto. exists (Const n); auto. intros. inversion H; auto. assert (forall x, In x l->ltof Term termDepth x (Func n l)). intros. unfold ltof. simpl. apply le_n_S. clear IH. induction l. destruct H. destruct H. subst x. simpl. apply Nat.le_max_r. simpl. eapply le_trans. eapply IHl; auto. apply Nat.le_max_l. remember (fun x=>match in_dec Term_eq_dec x l with |left _ H0 => let (y,_,_):=IH x (H x H0) in y |right _ _=> Var 0 end) as f. assert (Hf: forall x, In x l-> SubTerm v t x (f x) /\ forall y, SubTerm v t x y->y=f x). intros. subst f. destruct (in_dec Term_eq_dec x l). destruct (IH x (H x i)). split; auto. contradiction. clear Heqf.  exists (Func n (map f l)). clear -Hf. induction l; auto. apply ST_func2; auto. destruct (Hf a); auto. clear -Hf. induction l; intros; simpl. inversion H; auto. inversion H. f_equal. f_equal. destruct (Hf a); auto. apply IHl in H4; auto. inversion H4; auto. Defined.
Definition sub: forall v t f, {g|Sub v t f g & forall g', Sub v t f g' -> g' = g}. induction f. exists (Pred n (map (fun u=>let (s,_,_):=subTerm v t u in s) l)). induction l; auto. simpl. apply Sub_pred2; auto. destruct (subTerm v t a); auto. induction l; simpl; intros. inversion H; auto. inversion H. subst i f l0 g'. f_equal. f_equal. destruct (subTerm v t a); auto. apply IHl in H5. inversion H5. auto. destruct IHf as [g H H0]. exists (!g); auto. intros. inversion H1. f_equal; auto. destruct IHf1 as [g1 H H0]. destruct IHf2 as [g2 H1 H2]. exists (g1==>g2); auto. intros. inversion H3. subst f0 f3 g'. f_equal; auto. destruct IHf as [g H H0]. destruct (nat_eq_dec n v). subst n. exists (Any v f); auto. intros. inversion H1; auto. contradict H4; auto. exists (Any n g); auto. intros. inversion H1. contradict n0; auto. f_equal; auto. Defined.
Definition BoundByRep_dec: forall x y f, {BoundByRep x y f}+{~BoundByRep x y f}. induction f. right. intros C; inversion C. destruct IHf; [left|right]; auto. contradict n; inversion n; auto. destruct IHf1; [left|destruct IHf2; [left|right]]; auto. intros C; inversion C; contradiction. destruct (nat_eq_dec n x). subst n. right. intros C; inversion C; contradict H1; auto. destruct (nat_eq_dec n y). subst n. destruct (freeVars f) as [l H]. destruct (in_dec nat_eq_dec x l). left. apply BBR_any1; auto. apply H; auto. destruct IHf; [left| right]; auto. intros C; inversion C. contradict n; apply H; auto. contradiction. destruct IHf; [left|right]; auto. intros C; inversion C. contradict n1; auto. contradiction. Defined.
Definition tffSub: forall v t f, {g|TFFSub v t f g & forall g', TFFSub v t f g' -> g'=g}+{forall g, ~TFFSub v t f g}. intros. destruct (sub v t f) as [g H H0]. destruct (freeVarsTerm t) as [l H1]. destruct Exists_dec with (P:=fun i=>BoundByRep v i f) (l:=l). intros. apply BoundByRep_dec. right. intros g' Hg. inversion Hg. apply Exists_exists in e. destruct e as [x [H6 H7]]. contradict H7. apply H3. apply H1; auto. left. exists g. apply TFFSub_intro; auto. intros. contradict n. apply Exists_exists. exists i; split; auto. apply H1; auto. intros. apply H0. inversion H2; auto. Defined.

Theorem FV_Or1: forall v f g, FreeVar v f -> FreeVar v (f |^ g). Proof. intros. unfold LQor. auto. Qed.
Theorem FV_Or2: forall v f g, FreeVar v g -> FreeVar v (f |^ g). Proof. intros. unfold LQor. auto. Qed.
Theorem FV_And1: forall v f g, FreeVar v f -> FreeVar v (f &^ g). Proof. intros. unfold LQand. auto. Qed.
Theorem FV_And2: forall v f g, FreeVar v g -> FreeVar v (f &^ g). Proof. intros. unfold LQand. auto. Qed.
Theorem FV_Ex: forall v i f, i<>v -> FreeVar v f -> FreeVar v (Ex i f). Proof. intros. unfold Ex. auto. Qed.
Theorem FV_Neg_inv: forall v f, FreeVar v (!f) -> FreeVar v f. Proof. intros. inversion H; auto. Qed.
Theorem FV_Imp_inv: forall v f g, FreeVar v (f==>g) -> FreeVar v f \/ FreeVar v g. Proof. intros. inversion H; auto. Qed.
Theorem FV_Any_inv1: forall v i f, FreeVar v (Any i f) -> FreeVar v f. Proof. intros. inversion H; auto. Qed.
Theorem FV_Any_inv2: forall v i f, FreeVar v (Any i f) -> i<>v. Proof. intros. inversion H; auto. Qed.
Theorem FV_Or_inv: forall v f g, FreeVar v (f |^ g) -> FreeVar v f \/ FreeVar v g. Proof. intros. inversion H; auto. inversion H1; auto. Qed.
Theorem FV_And_inv: forall v f g, FreeVar v (f &^ g) -> FreeVar v f \/ FreeVar v g. Proof. intros. inversion H; auto. inversion H1; auto. inversion H3; auto. Qed.
Theorem FV_Ex_inv1: forall v i f, FreeVar v (Ex i f) -> FreeVar v f. Proof. intros. inversion H; auto. inversion H1; auto. inversion H5; auto. Qed.
Theorem FV_Ex_inv2: forall v i f, FreeVar v (Ex i f) -> i<>v. Proof. intros. inversion H; auto. inversion H1; auto. Qed.
Hint Resolve FV_Or1 FV_Or2 FV_And1 FV_And2 FV_Ex FV_Imp_inv FV_Any_inv1 FV_Any_inv2 FV_Or_inv FV_And_inv FV_Ex_inv1 FV_Ex_inv2.

Theorem SubTermSelf: forall v t, SubTerm v (Var v) t t. Proof. intros v. apply (Fix (well_founded_ltof Term termDepth)). intros t IH. destruct t; auto. destruct (nat_eq_dec n v). subst n; auto. auto. induction l; auto. apply ST_func2. apply IHl. intros. apply IH. unfold ltof. unfold ltof in H. apply lt_le_trans with (termDepth (Func n l)); auto. simpl. apply le_n_S. apply Nat.le_max_l. apply IH. unfold ltof. simpl. apply le_n_S. apply Nat.le_max_r. Qed.
Theorem SubSelf: forall v f, Sub v (Var v) f f. Proof. induction f; auto. induction l; auto. apply Sub_pred2; auto. apply SubTermSelf; auto. destruct (nat_eq_dec n v). subst n; auto. auto. Qed.
Theorem SubTerm_noFV: forall v u t, ~FreeVarTerm v t -> SubTerm v u t t. Proof. intros v u t. apply (Fix (well_founded_ltof Term termDepth)) with (P:=fun t=>~FreeVarTerm v t->SubTerm v u t t). clear t. intros t IH H. destruct t. apply ST_var2. contradict H; subst n; auto. auto. revert H. revert IH. induction l; intros; auto. apply ST_func2. apply IHl; auto. intros. apply IH; auto. unfold ltof. unfold ltof in H0. apply lt_le_trans with (termDepth (Func n l)); auto. simpl. apply le_n_S. apply Nat.le_max_l. contradict H. inversion H. apply FVT_func with t; auto. apply IH. unfold ltof. simpl. apply le_n_S. apply Nat.le_max_r. contradict H. apply FVT_func with a; auto. Qed.
Theorem Sub_noFV: forall v t f, ~FreeVar v f -> Sub v t f f. Proof. induction f; intros. revert H. induction l; intros; auto. apply Sub_pred2. apply SubTerm_noFV; auto. contradict H. apply FV_pred with a; auto. apply IHl. contradict H. inversion H. apply FV_pred with t0; auto. apply Sub_neg. apply IHf; auto. apply Sub_imp; auto. destruct (nat_eq_dec n v). subst n; auto. apply Sub_any2; auto. Qed.
Theorem TFFSub_noFV: forall v t f, ~FreeVar v f -> TFFSub v t f f. Proof. intros. apply TFFSub_intro. apply Sub_noFV; auto. intros. contradict H. clear H0. induction H; auto. Qed.
Theorem TFFSubSelf: forall v f, TFFSub v (Var v) f f. Proof. intros. apply TFFSub_intro. apply SubSelf. intros. inversion H. clear H H1. induction f; intros C. inversion C. inversion C. contradiction. inversion C; contradiction. inversion C. contradict H1; auto. contradiction. Qed.
Theorem SubTerm_noFreeVar: forall v t u s, SubTerm v t u s -> ~FreeVarTerm v t -> ~FreeVarTerm v s. Proof. intros v t u s H H0. revert H. revert s. apply (Fix (well_founded_ltof Term termDepth)) with (P:=fun u=>forall s,SubTerm v t u s->~FreeVarTerm v s). clear u. intros u IH s H. destruct u. inversion H. subst s n; auto. contradict H2; inversion H2; auto. inversion H. intros C; inversion C. inversion H. intros C; inversion C. destruct H7. subst i l s. intros C. inversion C. subst i l. destruct H6. subst t0. contradict H4. apply IH with f; auto. unfold ltof. simpl. apply le_n_S. apply Nat.le_max_r.  contradict H4. clear -IH H3 H1. revert H3. revert IH. revert l0. induction m; intros. destruct H1. inversion H3. subst i l0 a m0. destruct H1. apply IH with f0; auto. unfold ltof. simpl. apply le_n_S. apply le_trans with (max (fold_right (fun t1 x => max x (termDepth t1)) 0 l) (termDepth f0)). apply Nat.le_max_r. apply Nat.le_max_l. rewrite <- H; auto. apply IHm with l; auto. intros. apply IH with y; auto. unfold ltof. unfold ltof in H0. apply lt_le_trans with (termDepth (Func n (f::l))); auto. simpl. apply le_n_S. remember (fold_right (fun (t1 : Term) (x : nat) => Init.Nat.max x (termDepth t1)) 0 l) as x. remember (termDepth f) as z. remember (termDepth f0) as w.
  clear -x z w. destruct (le_lt_dec x w). rewrite max_r with x w; auto. destruct (le_lt_dec w z). rewrite max_r with w z; auto. rewrite max_r; auto. apply le_trans with w; auto. rewrite max_l with w z; auto. destruct (le_lt_dec x z). rewrite max_r; auto. rewrite max_l; auto. rewrite max_l with x w; auto. Qed.
Theorem Sub_noFreeVar: forall v t f g, Sub v t f g -> ~FreeVarTerm v t -> ~FreeVar v g. Proof. intros v t f g H. induction H; intros. intros C; inversion C. destruct H3. intros C. inversion C. subst i0 l0. destruct H5. subst t0. contradict H4. apply SubTerm_noFreeVar with t f; auto. apply IHSub in H1. apply H1. clear -H4 H2. apply FV_pred with t0; auto. apply IHSub in H0. contradict H0; inversion H0; auto. intros C. inversion C; contradict H3; auto. contradict H. inversion H. contradict H2; auto. apply IHSub in H1. contradict H1. inversion H1; auto. Qed.
Theorem SubTermRev: forall v u t s, ~FreeVarTerm u t -> SubTerm v (Var u) t s -> SubTerm u (Var v) s t. Proof. intros v u t. apply (Fix (well_founded_ltof Term termDepth)) with (P:=fun t=>forall s, ~FreeVarTerm u t->SubTerm v (Var u) t s->SubTerm u (Var v) s t). clear t. intros t IH s. intros. destruct t. inversion H0; auto. subst i s. apply ST_var2. contradict H. subst u; auto. inversion H0; auto. revert H0. revert H. revert IH. revert s. induction l; intros. inversion H0; auto. inversion H0. subst i f l0 s. apply ST_func2. apply IHl; auto. intros. apply IH; auto. unfold ltof. unfold ltof in H1. apply lt_le_trans with (termDepth (Func n l)); auto. simpl. apply le_n_S. apply Nat.le_max_l. contradict H. inversion H. apply FVT_func with t; auto. apply IH; auto. unfold ltof. simpl. apply le_n_S. apply Nat.le_max_r. contradict H. apply FVT_func with a; auto. Qed.
Theorem TFFSubRev: forall v u f g, ~FreeVar u f -> TFFSub v (Var u) f g -> TFFSub u (Var v) g f. Proof. induction f; intros. inversion H0. subst f g0. clear H2 H0. revert H1. revert H. revert g. induction l; intros. inversion H1. apply TFFSub_intro; auto. intros. intros C; inversion C. inversion H1. subst i f l0 g. apply TFFSub_intro. apply Sub_pred2; auto. apply SubTermRev; auto. contradict H. apply FV_pred with a; auto. apply IHl in H6. inversion H6; auto. contradict H. inversion H. apply FV_pred with t; auto. intros. intros C. inversion C. inversion H0. subst f0 g0. inversion H1. subst f0 g. assert (TFFSub v (Var u) f g0). apply TFFSub_intro; auto. intros. apply H2 in H3. contradict H3; auto. apply IHf in H3. inversion H3. apply TFFSub_intro; auto. intros. apply H6 in H9. contradict H9; inversion H9; auto. contradict H; auto. inversion H0. subst f g0. inversion H1. subst f0 f3 g. assert (TFFSub v (Var u) f1 g1). apply TFFSub_intro; auto. intros. apply H2 in H3. contradict H3; auto. assert (TFFSub v (Var u) f2 g2). apply TFFSub_intro; auto. intros. apply H2 in H4. contradict H4; auto. apply IHf1 in H3. apply IHf2 in H4. inversion H3. inversion H4. subst f g f0 g0. apply TFFSub_intro; auto. intros. intros C. inversion C; contradict H13; auto. contradict H; auto. contradict H; auto. inversion H0. subst f0 g0. assert (~BoundByRep v u (Any n f)). apply H2; auto. clear H2 H0. inversion H1. subst n f0 g.
  destruct (nat_eq_dec u v). subst u. apply TFFSub_intro; auto. intros; intros C; inversion C; contradict H5; auto. apply TFFSub_noFV; auto. subst i f0 g. destruct (nat_eq_dec n u). subst n. destruct (freeVars f) as [fl H7]. destruct (in_dec nat_eq_dec v fl). apply H7 in i. contradict H3; auto. replace g0 with f. apply TFFSub_noFV; auto. destruct (sub v (Var u) f) as [g H8 H9]. apply H9 in H6. subst g0. apply H9. apply Sub_noFV. contradict n; apply H7; auto. assert (TFFSub v (Var u) f g0). apply TFFSub_intro; auto. intros. inversion H0. subst i. contradict H3; auto. apply IHf in H0. inversion H0. subst f0 g. apply TFFSub_intro. apply Sub_any2; auto. intros. inversion H7. subst i. intros C. inversion C. contradict H4; auto. subst i f0. inversion H0. contradict H11. apply H9; auto. contradict H; auto. Qed.
Theorem BBR_FreeVar: forall x y f, BoundByRep x y f -> FreeVar x f. Proof. intros. induction H; auto. Qed.
Theorem BBR_VarIn: forall x y f, BoundByRep x y f -> VarIn y f. Proof. intros. induction H; auto. Qed.
Theorem FreeVar_VarIn: forall x f, FreeVar x f -> VarIn x f. Proof. intros. induction H; auto. apply VI_pred with t; auto. Qed.
Hint Resolve SubTermSelf SubSelf SubTerm_noFV Sub_noFV TFFSub_noFV TFFSubSelf SubTerm_noFreeVar Sub_noFreeVar SubTermRev TFFSubRev BBR_FreeVar BBR_VarIn FreeVar_VarIn.

Theorem InfMp: forall pre f g, LQInf pre (f==>g) -> LQInf pre f -> LQInf pre g. Proof. intros. apply LQIMp with f pre pre; auto. Qed.
Theorem ImpRefl: forall pre f, LQInf pre (f==>f). Proof. intros. apply LQIMp with (f==>f==>f) pre pre; auto. apply LQIMp with (f==>(f==>f)==>f) pre pre; auto. Qed.
Theorem LQInf_incl: forall l m f, LQInf l f -> incl l m -> LQInf m f. Proof. intros. apply LQIMp with f m l; auto. apply ImpRefl. Qed.
Theorem LQInf_incl1: forall p l f, LQInf l f -> LQInf (p::l) f. Proof. intros. apply LQInf_incl with l; auto. Qed.
Theorem LQTh_LQInf': forall f, LQTheorem f -> LQInf nil f. Proof. intros. induction H; auto. apply LQIMp with f nil nil; auto. Qed.
Theorem LQTh_LQInf: forall pre f, LQTheorem f -> LQInf pre f. Proof. intros. apply LQInf_incl with nil. apply LQTh_LQInf'; auto. intros x Hx. destruct Hx. Qed.
Theorem LQInf_LQTh: forall f, LQInf nil f -> LQTheorem f. Proof. intros. remember nil as l. revert Heql. induction H; intros; auto; subst pre. destruct H. apply incl_l_nil in H0. apply incl_l_nil in H. subst p1 p2. apply LQMp with f; auto. Qed.
Theorem InfTh': forall p l f, LQInf l f -> LQInf (remove Formula_eq_dec p l) (p==>f). Proof. intros. induction H; intros. apply InfMp with f; auto. destruct (Formula_eq_dec f p). subst p. apply ImpRefl. apply InfMp with f; auto. apply InfMp with (p==>f). apply InfMp with (p==>f==>g); auto. apply LQInf_incl with (remove Formula_eq_dec p p1); auto. apply LQInf_incl with (remove Formula_eq_dec p p2); auto. destruct (in_dec Formula_eq_dec p pre). apply InfMp with (Any v (p==>f)); auto. apply LQIUg; auto. intros q Hq. apply H. apply remove_In2 in Hq; auto. apply InfMp with (Any v f); auto. rewrite remove_notIn; auto. Qed.
Theorem InfTh: forall p l m f, Add p l m -> LQInf m f -> LQInf l (p==>f). Proof. intros. apply LQInf_incl with (remove Formula_eq_dec p m). apply InfTh'; auto. intros x Hx. apply Add_in with (x:=x) in H. assert (In x m). apply remove_In2 in Hx; auto. apply H in H1. destruct H1. subst x. contradict Hx. apply remove_In. auto. Defined.
Theorem InfTh1: forall p l f, LQInf (p::l) f -> LQInf l (p==>f). Proof. intros. apply InfTh with (p::l); auto. Qed.

Hint Resolve InfMp ImpRefl LQInf_incl LQInf_incl1 LQTh_LQInf LQInf_LQTh InfTh' InfTh InfTh1.

Theorem ImpIntro: forall pre f g, LQInf pre f -> LQInf pre (g==>f). Proof. intros. apply InfMp with f; auto. Qed.
Theorem ImpTrans: forall pre f g h, LQInf pre (f==>g) -> LQInf pre (g==>h) -> LQInf pre (f==>h). Proof. intros. apply InfTh1. apply InfMp with g; auto. apply InfMp with f; auto. Qed.
Theorem Absurd: forall pre f g, LQInf pre f -> LQInf pre (!f) -> LQInf pre g. Proof. intros. apply InfMp with f; auto. apply InfMp with (!g==>!f); auto. Qed.
Theorem Contra: forall pre f g, LQInf ((!f)::pre) g -> LQInf ((!f)::pre) (!g) -> LQInf pre f. Proof. intros. apply InfMp with (f==>f); auto. apply InfMp with (!f ==> !(f==>f)); auto. apply InfTh1. apply Absurd with g; auto. Qed.
Theorem NegElim: forall pre f, LQInf pre (!(!f)) -> LQInf pre f. Proof. intros. apply InfMp with (f==>f); auto. apply InfMp with (!f ==> !(f==>f)); auto. apply InfMp with (!(!(f==>f)) ==> !(!f)); auto. Qed.
Theorem NegIntro: forall pre f, LQInf pre f -> LQInf pre (!(!f)). Proof. intros. apply Contra with f; auto. apply NegElim; auto. Qed.
Theorem DualImp: forall pre f g, LQInf pre (f==>g) -> LQInf pre (!f ==>g) -> LQInf pre g. Proof. intros. apply Contra with f. apply InfMp with (!g); auto. apply InfMp with (!f==>!(!g)); auto. apply ImpTrans with g; auto. apply InfTh1. apply NegIntro; auto. apply InfMp with (!g); auto. apply InfMp with (!(!f) ==> !(!g)); auto. apply ImpTrans with f; auto. apply InfTh1. apply NegElim; auto. apply ImpTrans with g; auto. apply InfTh1. apply NegIntro; auto. Qed.

Hint Resolve ImpIntro ImpTrans Absurd Contra NegElim NegIntro DualImp.

Theorem OrIntro1: forall pre f g, LQInf pre f -> LQInf pre (f|^g). Proof. intros. apply InfTh1. apply Absurd with f; auto. Qed.
Theorem OrIntro2: forall pre f g, LQInf pre g -> LQInf pre (f|^g). Proof. intros. apply InfTh1. auto. Qed.
Theorem OrElim: forall pre f g h, LQInf pre (f==>h) -> LQInf pre (g==>h) -> LQInf pre (f |^g) -> LQInf pre h. Proof. intros. apply DualImp with f; auto. apply ImpTrans with g; auto. Qed.
Theorem AndIntro: forall pre f g, LQInf pre f -> LQInf pre g -> LQInf pre (f&^g). Proof. intros. apply Contra with g; auto. apply InfMp with f; auto. Qed.
Theorem AndElim1: forall pre f g, LQInf pre (f&^g) -> LQInf pre f. Proof. intros. apply Contra with (f==>!g); auto. apply InfTh1. apply Absurd with f; auto. Qed.
Theorem AndElim2: forall pre f g, LQInf pre (f&^g) -> LQInf pre g. Proof. intros. apply Contra with (f==>!g); auto. Qed.

Hint Resolve OrIntro1 OrIntro2 OrElim AndIntro AndElim1 AndElim2.

Theorem LQIUi: forall pre v t f g, LQInf pre (Any v f) -> TFFSub v t f g -> LQInf pre g. Proof. intros. apply InfMp with (Any v f); auto. apply LQIAx. apply LQA4 with t; auto. Qed.
Theorem LQIEg: forall pre v t f g, TFFSub v t f g -> LQInf pre g -> LQInf pre (Ex v f). Proof. intros. unfold Ex. apply Contra with g; auto. apply LQIUi with v t (!f); auto. inversion H. apply TFFSub_intro; auto. intros. intros C. inversion C. contradict H7; auto. Qed.
Theorem Any_rename: forall pre v v' f f', ~FreeVar v' f -> TFFSub v (Var v') f f' -> LQInf pre (Any v f) -> LQInf pre (Any v' f'). Proof. intros. apply LQIMp with (Any v f) nil pre; auto. apply InfTh1. apply LQIUg. intros. destruct H2. subst p. contradict H. inversion H; auto. destruct H2. apply LQIUi with v (Var v') f; auto. Qed.
Theorem LQIEi: forall pre v v' f f' g, (forall p, In p pre -> ~FreeVar v' p) -> ~FreeVar v' f -> ~FreeVar v' g -> TFFSub v (Var v') f f' -> LQInf pre (f'==>g) -> LQInf pre (Ex v f) -> LQInf pre g. Proof. unfold Ex. intros. destruct (nat_eq_dec v' v). subst v'. apply Contra with (Any v (! f)); auto. apply LQIUg. intros. destruct H5. subst p. contradict H1; inversion H1; auto. auto. assert (f'=f). destruct (tffSub v (Var v) f) as [[f'' H5]|H5]. apply e in H2. rewrite H2. symmetry; auto. contradict H2; auto. subst f'. apply Contra with g; auto. apply InfMp with f; auto.
  apply Contra with (Any v (!f)); auto. apply Any_rename with v' (!f'); auto. apply Sub_noFreeVar with (Var v') (!f). inversion H2; auto. intros C. inversion C. contradict n; auto. apply TFFSubRev. contradict H0; inversion H0; auto. inversion H2. apply TFFSub_intro; auto. intros. apply H6 in H9. contradict H9; auto. inversion H9; auto. apply LQIUg. intros. destruct H5. subst p. contradict H1. inversion H1; auto. auto. apply Contra with g; auto. apply InfMp with f'; auto. Qed.

Hint Resolve LQIUi LQIEg Any_rename LQIEi.

Theorem Ex_rename: forall pre v v' f f', ~FreeVar v' f -> TFFSub v (Var v') f f' -> LQInf pre (Ex v f) -> LQInf pre (Ex v' f'). Proof. intros. apply LQIMp with (Ex v f) nil pre; auto. apply InfTh1. apply LQIEi with v v' f f'; auto. intros. destruct H2. subst p. contradict H. inversion H. inversion H3. inversion H7; auto. destruct H2. intros C. inversion C. inversion H3. contradict H6; auto. apply InfTh1. apply LQIEg with (Var v') f'; auto. Qed.
Theorem Any_swap: forall pre x y f, LQInf pre (Any x (Any y f)) -> LQInf pre (Any y (Any x f)). Proof. intros. apply LQIMp with (Any x (Any y f)) nil pre; auto. apply InfTh1. apply LQIUg. intros. destruct H0. subst p. intros C. inversion C. inversion H3. contradict H6; auto. destruct H0. apply LQIUg. intros. destruct H0. subst p. intros C. inversion C. contradict H2; auto. destruct H0. apply LQIMp with (Any y f) nil (Any x (Any y f)::nil); auto. apply InfTh1. apply LQIUi with y (Var y) f; auto. apply LQIUi with x (Var x) (Any y f); auto. Qed.
Theorem ExAny_AnyEx: forall pre x y f, LQInf pre (Ex x (Any y f)) -> LQInf pre (Any y (Ex x f)). Proof. intros. apply LQIMp with (Ex x (Any y f)) nil pre; auto. apply InfTh1. apply LQIUg. intros. destruct H0. subst p. intros C. apply FV_Ex_inv1 in C. apply FV_Any_inv2 in C. contradict C; auto. destruct H0. destruct (nat_eq_dec y x). subst y. apply LQIEi with x x (Any x f) (Any x f); auto. intros. destruct H0. subst p. intros C. apply FV_Ex_inv2 in C. contradict C; auto. destruct H0. intros C. apply FV_Any_inv2 in C. contradict C; auto. intros C. apply FV_Ex_inv2 in C. contradict C; auto. apply InfTh1. apply LQIEg with (Var x) f; auto. apply LQIUi with x (Var x) f; auto.
  destruct (varsIn f) as [l H0]. destruct (ubound_sig (x::y::l)) as [z H1 H2]. assert (z<>x). intros C. subst x. absurd (z<z); auto. assert (z<>y). intros C. subst y. absurd (z<z); auto. assert (~In z l). intros C. absurd (z<z); auto. clear H1 H2. destruct (tffSub x (Var z) f) as [[f' H1 H2]|H1]. apply LQIEi with x z (Any y f) (Any y f'); auto. intros. destruct H6. subst p. intros C. apply FV_Ex_inv1 in C. apply FV_Any_inv1 in C. contradict H5; apply H0; auto. destruct H6. intros C. apply FV_Any_inv1 in C. contradict H5; apply H0; auto. intros C. contradict H5. apply H0. apply FV_Ex_inv1 in C; auto.
  inversion H1. subst f0 g. apply TFFSub_intro; auto. intros. inversion H8. subst i. intros C. apply BBR_VarIn in C. inversion C. contradict H5; apply H0; auto. contradiction. apply InfTh1. apply LQIEg with (Var z) f'; auto. apply LQIUi with y (Var y) f'; auto. destruct (sub x (Var z) f) as [g H6 H7]. absurd (TFFSub x (Var z) f g); auto. apply TFFSub_intro; auto. intros. intros C. inversion H2. subst i. apply BBR_VarIn in C. contradict H5. apply H0; auto. Qed.
Theorem AnyAnd_dist1: forall pre v f g, LQInf pre (Any v f &^ Any v g) -> LQInf pre (Any v (f &^ g)). Proof. intros. apply LQIMp with (Any v f &^ Any v g) nil pre; auto. apply InfTh1. clear H. apply LQIUg. intros. destruct H. subst p. intros C. apply FV_And_inv in C. destruct C; apply FV_Any_inv2 in H; contradict H; auto. destruct H. apply AndIntro. apply InfMp with (Any v f). apply InfTh1. apply LQIUi with v (Var v) f; auto. eapply AndElim1; eauto. apply InfMp with (Any v g); auto. apply InfTh1. apply LQIUi with v (Var v) g; auto. eapply AndElim2; eauto. Qed.
Theorem AnyAnd_dist2: forall pre v f g, LQInf pre (Any v (f &^ g)) -> LQInf pre (Any v f &^ Any v g). Proof. intros. apply AndIntro. apply LQIMp with (Any v (f&^g)) nil pre; auto. apply InfTh1. apply LQIUg. intros. destruct H0. subst p. intros C. apply FV_Any_inv2 in C. contradict C; auto. destruct H0. apply InfMp with (f &^g). apply InfTh1. eapply AndElim1; eauto. apply LQIUi with v (Var v) (f&^g); auto. apply LQIMp with (Any v (f&^g)) nil pre; auto. apply InfTh1. apply LQIUg. intros. destruct H0. subst p. intros C. inversion C. contradict H2; auto. destruct H0. apply InfMp with (f&^g). apply InfTh1. eapply AndElim2; eauto. apply LQIUi with v (Var v) (f&^g); auto. Qed.
Theorem AnyOr_dist1: forall pre v f g, LQInf pre (Any v f |^ Any v g) -> LQInf pre (Any v (f |^ g)). Proof. intros. apply LQIMp with (Any v f |^ Any v g) nil pre; auto. apply InfTh1. apply LQIUg. intros. destruct H0. subst p. intros C. apply FV_Or_inv in C. destruct C; apply FV_Any_inv2 in H0; contradict H0; auto. destruct H0. apply OrElim with (Any v f) (Any v g); auto; apply InfTh1; [apply OrIntro1|apply OrIntro2]; eapply LQIUi with (v:=v) (t:=Var v); eauto. Qed.
Theorem ExAnd_dist1: forall pre v f g, LQInf pre (Ex v (f &^g)) -> LQInf pre (Ex v f &^ Ex v g). Proof. intros. apply LQIMp with (Ex v (f&^g)) nil pre; auto. apply InfTh1. destruct (varsIn (f&^g)) as [l H0]. destruct (ubound_sig (v::l)) as [x H1 _]. assert (Hx:~In x l). intros C. absurd (x<x); auto. destruct (tffSub v (Var x) f) as [[f' H2 _]|H2]. destruct (tffSub v (Var x) g) as [[g' H3 _]|H3]. apply LQIEi with v x (f &^g) (f' &^g'); auto. intros. destruct H4. subst p. contradict Hx. apply H0. apply FV_Ex_inv1 in Hx; auto. destruct H4. contradict Hx; apply H0; auto. contradict Hx; apply H0. apply FV_And_inv in Hx. destruct Hx; apply FV_Ex_inv1 in H4; auto.
  inversion H2. inversion H3. apply TFFSub_intro; unfold LQand; auto. intros i H12 C. inversion C. inversion H14. contradict H16; auto. inversion H16. contradict H19; auto. apply InfTh1. apply AndIntro. apply LQIEg with (Var x) f'; auto. apply AndElim1 with g'; auto. apply LQIEg with (Var x) g'; auto. apply AndElim2 with f'; auto.
  destruct (sub v (Var x) g) as [g' H4 _]. absurd (TFFSub v (Var x) g g'); auto. apply TFFSub_intro; auto. intros. intros C. inversion H5. subst i. apply BBR_VarIn in C. absurd (x<x); auto. apply H1. right. apply H0. unfold LQand; auto. destruct (sub v (Var x) f) as [f' H3 _]. absurd (TFFSub v (Var x) f f'); auto. apply TFFSub_intro; auto. intros. inversion H4. subst i. intros C. apply BBR_VarIn in C. absurd (x<x); auto. apply H1. right. apply H0. unfold LQand; auto. Qed.
Theorem ExOr_dist1: forall pre v f g, LQInf pre (Ex v f |^ Ex v g) -> LQInf pre (Ex v (f|^g)). Proof. intros. apply LQIMp with (Ex v f|^Ex v g) nil pre; auto. apply InfTh1. destruct (varsIn f) as [l1 H0]. destruct (varsIn g) as [l2 H1]. destruct (ubound_sig (v::l1++l2)) as [x H3 _]. destruct (sub v (Var x) f) as [f' H4 _]. assert (TFFSub v (Var x) f f'). apply TFFSub_intro; auto. intros. inversion H2. subst i. intros C. apply BBR_VarIn in C. absurd (x<x); auto. apply H3. right. apply in_or_app; left; apply H0; auto. destruct (sub v (Var x) g) as [g' H5 _]. assert (TFFSub v (Var x) g g'). apply TFFSub_intro; auto. intros. inversion H6. subst i. intros C. apply BBR_VarIn in C. absurd (x<x); auto. apply H3. right; apply in_or_app; right; apply H1; auto. assert (~FreeVar x (Ex v (f|^g))). intros C. inversion C. inversion H8.  inversion H12. absurd (x<x); auto. apply H3. right. apply in_or_app. inversion H14; [left|right]. apply H0. inversion H16; auto. apply H1; auto.
  apply OrElim with (Ex v f) (Ex v g); auto; apply LQInf_incl with nil; auto; apply InfTh1. apply LQIEi with v x f f'; auto. intros. destruct H8. subst p. intros C. inversion C. inversion H9. inversion H13. absurd (x<x); auto. apply H3. right. apply in_or_app. left. apply H0; auto. destruct H8. intros C. absurd (x<x); auto. apply H3. right. apply in_or_app. left. apply H0; auto. apply InfTh1. apply LQIEg with (Var x) (f' |^ g'); auto. apply TFFSub_intro; auto. apply Sub_imp; auto. intros. inversion H8. subst i. intros C. inversion C. inversion H10. inversion H2. contradict H13; auto. inversion H6. contradict H10; auto.
  apply LQIEi with v x g g'; auto. intros. destruct H8. subst p. intros C. inversion C. inversion H9. inversion H13. absurd (x<x); auto. apply H3. right; apply in_or_app; right; apply H1; auto. destruct H8. intros C. absurd (x<x); auto. apply H3. right; apply in_or_app; right; apply H1; auto. apply InfTh1. apply LQIEg with (Var x) (f' |^ g'); auto. unfold LQor. apply TFFSub_intro; auto. intros. inversion H8. subst i. intros C. inversion C. inversion H10. inversion H2. contradict H13; auto. inversion H6. contradict H10; auto. Qed.
Theorem ExOr_dist2: forall pre v f g, LQInf pre (Ex v (f|^g)) -> LQInf pre (Ex v f |^ Ex v g). Proof. intros. apply LQIMp with (Ex v (f|^g)) nil pre; auto. apply InfTh1. destruct (varsIn f) as [l1 H1]. destruct (varsIn g) as [l2 H2]. destruct (ubound_sig (v::l1++l2)) as [x H3 _]. destruct (sub v (Var x) f) as [f' H4 _]. destruct (sub v (Var x) g) as [g' H5 _]. apply LQIEi with v x (f|^g) (f'|^g'); auto. intros. destruct H0. subst p. intros C. inversion C. inversion H6. inversion H10. absurd (x<x); auto. apply H3. right. apply in_or_app. inversion H12; [left|right]. apply H1. inversion H14; auto. apply H2; auto. destruct H0. intros C. absurd (x<x); auto. apply H3. right; apply in_or_app. inversion C; [left|right]. apply H1. inversion H6; auto. apply H2; auto. intros C. absurd (x<x); auto. apply H3. right. apply in_or_app. inversion C; [left|right]. apply H1. inversion H6. inversion H9. inversion H11. inversion H15; auto. apply H2. inversion H6. inversion H9. inversion H13; auto. unfold LQor. apply TFFSub_intro; auto. intros. inversion H0. subst i. intros C. apply BBR_VarIn in C. absurd (x<x); auto. apply H3. right. apply in_or_app. inversion C; [left|right]. apply H1. inversion H7; auto. apply H2; auto.
  apply InfTh1. apply OrElim with f' g'; auto; apply InfTh1. apply OrIntro1. apply LQIEg with (Var x) f'; auto. apply TFFSub_intro; auto. intros. inversion H0. subst i. intros C. apply BBR_VarIn in C. absurd (x<x); auto. apply H3. right; apply in_or_app; left; apply H1; auto. apply OrIntro2. apply LQIEg with (Var x) g'; auto. apply TFFSub_intro; auto. intros. inversion H0. subst i. intros C. apply BBR_VarIn in C. absurd (x<x); auto. apply H3. right; apply in_or_app; right; apply H2; auto. Qed.

Hint Resolve Ex_rename Any_swap ExAny_AnyEx AnyAnd_dist1 AnyAnd_dist2 AnyOr_dist1 ExAnd_dist1 ExOr_dist1 ExOr_dist2.


Require Import util db.
Import ListNotations.

Inductive closure := | close : tm → list closure → closure.
Definition env := list closure.

Inductive step : closure → closure → Type :=
  | Abs : ∀ b e, step (close (lam b) e) (close (lam b) e)
  | Var : ∀ x e v c, nth_error e x = Some c → step c v → step (close (var x) e) v
  | App : ∀ m n b e v mve,
      step (close m e) (close (lam b) mve) →
      step (close b (close n e::mve)) v →
      step (close (app m n) e) v.


(* Consecutive and non-consecutive transpositions.
   Decomposition of a non-consecutive transpositions into a composition of consecutive ones. *)

From Coq Require Import Bool PeanoNat Lia.
From OLlibs Require Import List_more.
Require Import List_nat Fun_nat.

Ltac length_lia := repeat (try rewrite concat_app;
                           try rewrite shift_length in *;
                           try rewrite app_length in *;
                           try rewrite seq_length in *;
                           try rewrite cfun_length in *;
                           try rewrite map_length in *; simpl in *); lia.

(** ** Transposition *)
Definition transpo m n :=
  if n <? m then
  (*[0...n-1,n+1   , n ,   n+2 ... m ]*)
    Id n ++ (S n) :: n :: (seq (2 + n) (S m - (2 + n))) else Id (S m).

Lemma transpo_decomp m n :
  n < m -> transpo m n = Id n ++ incr_all ((1 :: 0 :: nil) ++ incr_all (Id (S m - (2 + n))) 2) n.
Proof.
intros Hle.
apply Nat.ltb_lt in Hle.
unfold transpo; rewrite Hle.
f_equal.
rewrite shift_app.
change (S n :: n :: seq (2 + n) (S m - (2 + n)))
  with ((S n :: n :: nil) ++ seq (2 + n) (S m - (2 + n))).
f_equal.
- simpl; f_equal; [lia | f_equal; lia].
- rewrite <- shift_plus.
  rewrite incr_all_seq; reflexivity.
Qed.

Lemma transpo_decomp2 m n :
   { prod (transpo m n = Id (S m)) (m <= n) }
 + { prod (transpo m n = Id n ++ incr_all ((1 :: 0 :: nil) ++ incr_all (Id (S m - (2 + n))) 2) n)
          (n < m) }.
Proof.
case_eq (n <? m); intros Hle; unfold transpo; rewrite Hle; [ right | left ]; split.
- rewrite <- transpo_decomp.
  + unfold transpo; rewrite Hle; reflexivity.
  + apply Nat.ltb_lt; assumption.
- apply Nat.ltb_lt; assumption.
- reflexivity.
- apply Nat.ltb_ge in Hle; lia.
Qed.

Ltac decomp_transpo m n :=
  destruct (transpo_decomp2 m n) as [[Ht Hltb] | [Ht Hltb]]; rewrite Ht;
  [ assert (Hlt := (proj2 (Nat.ltb_ge _ _)) Hltb)
  | assert (Hlt := (proj2 (Nat.ltb_lt _ _)) Hltb) ].

Lemma transpo_length : forall m n, length (transpo m n) = (S m).
Proof.
intros m n; decomp_transpo m n.
- apply seq_length.
- rewrite app_length; simpl.
  rewrite 2 shift_length.
  rewrite 2 seq_length ; lia.
Qed.

Lemma all_lt_transpo : forall m n, all_lt (transpo m n) (S m) = true.
Proof.
intros m n; decomp_transpo m n.
- apply all_lt_seq; lia.
- rewrite all_lt_app.
  apply andb_true_iff; split.
  + apply all_lt_seq; lia.
  + replace (S m) with (n + (S m - n)) by lia.
    rewrite all_lt_shift_true; [ reflexivity | ].
    rewrite all_lt_app.
    apply andb_true_iff; split.
    * apply all_lt_leq with 2; [ reflexivity | lia].
    * replace (S m - n) with (2 + (S m - (2 + n))) at 2 by lia.
      rewrite all_lt_shift_true; [ reflexivity | ].
      apply all_lt_seq; lia.
Qed.

Lemma all_distinct_transpo : forall m n, all_distinct (transpo m n) = true.
Proof.
intros m n; decomp_transpo m n.
- apply all_distinct_seq.
- apply all_distinct_app; [ | | apply all_distinct_app ];
    try reflexivity; try apply all_distinct_seq.
  apply all_lt_seq; lia.
Qed.

Definition compo_transpo m := fold_right (fun i => app_nat_fun (transpo m i)) (Id (S m)).

Lemma compo_transpo_length : forall m l, length (compo_transpo m l) = S m.
Proof.
  intros m; induction l.
  - apply seq_length.
  - simpl; rewrite app_nat_fun_length; rewrite transpo_length; now try rewrite IHl.
Qed.

Lemma all_lt_compo_transpo : forall m l, all_lt (compo_transpo m l) (S m) = true.
Proof.
  intros m; induction l.
  - apply all_lt_seq; lia.
  - simpl; rewrite all_lt_app_nat_fun; [ reflexivity | | assumption ].
    rewrite compo_transpo_length.
    apply all_lt_transpo.
Qed.

Lemma app_compo_transpo : forall m l1 l2,
  compo_transpo m (l1 ++ l2) = app_nat_fun (compo_transpo m l1) (compo_transpo m l2).
Proof.
intros.
apply fold_right_app_assoc2.
- symmetry; apply asso_app_nat_fun.
- fold (compo_transpo m).
  rewrite <- (app_nil_r (compo_transpo _ _)) at 1.
  apply app_Id_ext, compo_transpo_length.
Qed.

Lemma compo_transpo_sg : forall m i,
  compo_transpo m (i :: nil) = transpo m i.
Proof.
intros m i.
unfold compo_transpo, fold_right.
apply app_nat_fun_Id_r, all_lt_transpo.
Qed.

(** ** nc_transpo *)
Definition nc_transpo m i j :=
  if (i <? j) && (j <=? m) then
 (*[0...i-1,j,   i+1...j-1 ,              i ,  j+1 ... m]*)
    Id i ++ j :: seq (S i) (j - (S i)) ++ i :: seq (S j) (m - j) else Id (S m).

Lemma nc_transpo_eq m i : nc_transpo m i i = Id (S m).
Proof.
unfold nc_transpo.
replace (i <? i) with false by (symmetry; apply Nat.ltb_ge; lia); reflexivity.
Qed.

Lemma nc_transpo_S m i : nc_transpo m i (S i) = transpo m i.
Proof.
case_eq (i <? m); intros Hlt; unfold nc_transpo, transpo.
- apply Nat.ltb_lt in Hlt.
  replace (i <? S i) with true by (symmetry; apply Nat.ltb_lt; lia).
  replace (S i <=? m) with true by (symmetry; apply Nat.leb_le; lia).
  replace (i <? m) with true by (symmetry; apply Nat.ltb_lt; lia); simpl.
  replace (i - i) with 0 by lia; reflexivity.
- apply Nat.ltb_ge in Hlt.
  replace (S i <=? m) with false by (symmetry; apply Nat.leb_gt; lia).
  replace (i <? m) with false by (symmetry; apply Nat.leb_gt; lia); simpl.
  destruct (i <? S i); reflexivity.
Qed.

Lemma app_nc_transpo {A} : forall (a b : A) l1 l2 l3 m i j,
  m = 1 + length l1 + length l2 + length l3 ->
  i = length l1 ->
  j = 1 + length l1 + length l2 ->
     app_nat_fun (nc_transpo m i j) (l1 ++ a :: l2 ++ b :: l3)
   = l1 ++ b :: l2 ++ a :: l3.
Proof.
intros a b l1 l2 l3 m i j Hm Hi Hj.
unfold nc_transpo.
replace (i <? j) with true by (symmetry; apply Nat.ltb_lt; lia).
replace (j <=? m) with true by (symmetry; apply Nat.leb_le; lia); simpl.
rewrite app_nat_fun_app.
rewrite app_Id_ext by lia.
f_equal.
replace (j :: seq (S i) (j - S i) ++ i :: seq (S j) (m - j))
   with (incr_all (S (length l2) :: seq 1 (length l2) ++ 0 :: seq (S (S (length l2))) (length l3)) i)
  by (repeat (simpl; rewrite ? shift_app; rewrite incr_all_seq); repeat (f_equal; try lia)).
rewrite app_nat_fun_right; try lia.
- replace (S (length l2) :: seq 1 (length l2) ++ 0 :: seq (S (S (length l2))) (length l3))
     with ((S (length l2) :: seq 1 (length l2) ++ 0 :: nil) ++ seq (0 + length (a :: l2 ++ b :: nil)) (length l3))
    by (list_simpl; rewrite app_length; simpl; do 4 f_equal; lia).
  replace (a :: l2 ++ b :: l3) with ((a :: l2 ++ b :: nil) ++ l3) by (list_simpl; reflexivity).
  rewrite app_nat_fun_app.
  rewrite app_nat_fun_left.
  + rewrite <- incr_all_seq.
    rewrite app_nat_fun_right; [ | lia | apply all_lt_seq; lia ].
    rewrite app_Id.
    rewrite app_nat_fun_cons, <- app_comm_cons; f_equal.
    * rewrite app_comm_cons, app_nth2; simpl;
        replace (length l2 - length l2) with 0 by lia; [ reflexivity | lia ].
    * rewrite app_nat_fun_app.
      change (a :: l2 ++ b :: nil) with ((a :: nil) ++ l2 ++ b :: nil).
      replace 1 with (0 + length (a :: nil)) by (simpl; lia).
      rewrite <- incr_all_seq.
      rewrite app_nat_fun_right; [ | |
        rewrite app_length; simpl; apply all_lt_leq with (length l2); [ apply all_lt_seq | ] ]; try lia.
      rewrite app_nat_fun_left, app_Id; [ | apply all_lt_seq; lia ].
      list_simpl; reflexivity.
  + simpl length.
    rewrite app_length; simpl.
    apply andb_true_iff; split; [ apply Nat.ltb_lt; lia | rewrite all_lt_app ].
    apply andb_true_iff; split; [ | reflexivity ].
    apply all_lt_leq with (1 + length l2); [ apply all_lt_seq| ]; lia.
- simpl length.
  rewrite app_length; simpl.
  apply andb_true_iff; split; [ apply Nat.ltb_lt; lia | rewrite all_lt_app ].
  apply andb_true_iff; split; [ | simpl ].
  + apply all_lt_leq with (1 + length l2); [ apply all_lt_seq | ]; lia.
  + replace (S (length l2 + S (length l3)))
       with (S (S (length l2)) + length l3) by lia.
    apply all_lt_seq; lia.
Qed.

Lemma nc_transpo_idem : forall m i j,
  app_nat_fun (nc_transpo m i j) (nc_transpo m i j) = Id (S m).
Proof.
intros m i j; unfold nc_transpo at 2.
case_eq (i <? j); intros Hij; [ case_eq (j <=? m); intros Hjm | ]; unfold andb.
- apply Nat.ltb_lt in Hij; apply Nat.leb_le in Hjm.
  rewrite app_nc_transpo; try length_lia.
  replace (S m) with (i + (S ((j - S i) + S (m - j)))) by lia.
  repeat (rewrite ? seq_app; f_equal; simpl); lia.
- unfold nc_transpo; rewrite Hij, Hjm; unfold andb.
  rewrite <- (app_nil_r (Id (S m))) at 2.
  apply app_Id_ext with (l2 := nil); length_lia.
- unfold nc_transpo; rewrite Hij; unfold andb.
  rewrite <- (app_nil_r (Id (S m))) at 2.
  apply app_Id_ext with (l2 := nil); length_lia.
Qed.

Lemma app_transpo {A} : forall (a b : A) l1 l2 m i,
  m = 1 + length l1 + length l2 ->
  i = length l1 ->
   app_nat_fun (transpo m i) (l1 ++ a :: b :: l2)
 = l1 ++ b :: a :: l2.
Proof.
intros a b l1 l2 m i Hm Hi.
rewrite <- nc_transpo_S.
change (l1 ++ a :: b :: l2) with (l1 ++ a :: nil ++ b :: l2).
rewrite app_nc_transpo; simpl; try lia; reflexivity.
Qed.

Lemma transpo_idem : forall m i,
  app_nat_fun (transpo m i) (transpo m i) = Id (S m).
Proof. intros; rewrite <- nc_transpo_S; apply nc_transpo_idem. Qed.

Lemma nc_transpo_transpo : forall m i j, S i < j -> j <= m ->
  nc_transpo m i j = app_nat_fun (app_nat_fun (transpo m i) (nc_transpo m (S i) j)) (transpo m i).
Proof.
intros m i j Hlt Hle.
rewrite asso_app_nat_fun.
unfold transpo at 2.
replace (i <? m) with true by (symmetry; apply Nat.ltb_lt; lia).
replace (S m - (2 + i)) with ((j - (2 + i)) + (S (m - j))) by lia.
rewrite seq_app.
replace (2 + i + (j - (2 + i))) with j by lia.
simpl seq at 3.
rewrite <- (app_nil_l (i :: _)).
rewrite app_comm_cons, app_assoc.
rewrite app_nc_transpo; try length_lia.
rewrite <- app_assoc, <- app_comm_cons, app_nil_l.
rewrite app_transpo; try length_lia.
unfold nc_transpo.
replace (i <? j) with true by (symmetry; apply Nat.ltb_lt; lia).
replace (j <=? m) with true by (symmetry; apply Nat.leb_le; lia); simpl.
list_simpl; do 2 f_equal.
replace (j - S i) with (S (j - S (S i))) at 1 by lia.
reflexivity.
Qed.

Lemma nc_transpo_transpo_2 : forall m i j, i < j -> S j <= m ->
  nc_transpo m i (S j) = app_nat_fun (app_nat_fun (transpo m j) (nc_transpo m i j)) (transpo m j).
Proof.
intros m i j Hlt Hle.
rewrite asso_app_nat_fun.
unfold transpo at 2.
replace (j <? m) with true by (symmetry; apply Nat.ltb_lt; lia).
replace j with (i + (S (j - S i))) at 4 by lia.
rewrite seq_app; simpl seq.
rewrite <- app_assoc, <- app_comm_cons.
rewrite app_nc_transpo; try length_lia.
rewrite app_comm_cons, app_assoc.
rewrite app_transpo; try length_lia.
unfold nc_transpo.
replace (i <? S j) with true by (symmetry; apply Nat.ltb_lt; lia).
replace (S j <=? m) with true by (symmetry; apply Nat.leb_le; lia); simpl.
list_simpl; do 2 f_equal.
replace (j - i) with (S (j - S i)) at 1 by lia.
rewrite seq_S.
replace (S i + (j - S i)) with j by lia.
list_simpl; reflexivity.
Qed.

Lemma nc_transpo_compo_transpo : forall m i j, i < j -> j <= m ->
  nc_transpo m i j = compo_transpo m (seq i (j - i - 1) ++ rev (seq i (j - i))).
Proof.
intros m i j.
remember (j - i) as k; revert i j Heqk; induction k; intros i j Hk Hlt Hle;
  [ lia | destruct (Nat.eq_dec k 0); subst ].
- replace j with (S i) by lia.
  simpl seq; simpl rev.
  replace (S i - 1 :: i :: nil) with ((i :: nil) ++ i :: nil) by (simpl; f_equal; lia).
  rewrite nc_transpo_S.
  now rewrite app_nil_l, compo_transpo_sg.
- simpl seq; simpl rev.
  destruct k; [ now contradiction n | ].
  replace (compo_transpo m (seq i (S k - 0) ++ rev (seq (S i) (S k)) ++ i :: nil))
     with (app_nat_fun (transpo m i)
          (app_nat_fun (compo_transpo m (seq (S i) k ++ rev (seq (S i) (S k)))) (transpo m i)))
    by (unfold compo_transpo at 2; simpl; f_equal; rewrite <- compo_transpo_sg, <- app_compo_transpo;
        list_simpl; reflexivity).
  replace (S k - 1) with k in IHk by lia.
  rewrite <- (IHk (S i) j); try lia.
  rewrite <- asso_app_nat_fun.
  apply nc_transpo_transpo; lia.
Qed.

Lemma decomp_nc_transpo : forall m i j,
  { l & nc_transpo m i j = compo_transpo m l}.
Proof.
intros m i j.
case_eq ((i <? j) && (j <=? m)); intros Handb.
- apply andb_true_iff in Handb as [Hlt Hle].
  apply Nat.ltb_lt in Hlt.
  apply Nat.leb_le in Hle.
  exists (seq i (j - i - 1) ++ rev (seq i (j - i))).
  apply nc_transpo_compo_transpo; lia.
- unfold nc_transpo; rewrite Handb.
  exists nil; reflexivity.
Qed.

Lemma nc_transpo_length : forall m i j,
  length (nc_transpo m i j) = S m.
Proof.
intros m i j.
destruct (decomp_nc_transpo m i j) as [l Heq]; rewrite Heq.
apply compo_transpo_length.
Qed.

Lemma all_lt_nc_transpo : forall m i j,
  all_lt (nc_transpo m i j) (S m) = true.
Proof.
intros m i j.
destruct (decomp_nc_transpo m i j) as [l Heq]; rewrite Heq.
apply all_lt_compo_transpo.
Qed.

Definition compo_nc_transpo m := fold_right (fun i => app_nat_fun (nc_transpo m (fst i) (snd i))) (Id (S m)).

Lemma compo_nc_transpo_length : forall m l,
  length (compo_nc_transpo m l) = S m.
Proof.
  intros m; induction l.
  - apply seq_length.
  - simpl; rewrite app_nat_fun_length; rewrite nc_transpo_length; now try rewrite IHl.
Qed.


(** * Category theory *)

(** While [Basics.CategoryOps] gives the _signatures_ of categorical
    operations, this module describes their properties. *)

(* begin hide *)
From Coq Require Import Setoid Morphisms.

From ITree.Basics Require Import
     CategoryOps
     CategoryFunctor.

Import Carrier.
Import CatNotations.
Local Open Scope cat.

Set Warnings "-future-coercion-class-field".
(* end hide *)

(** ** Categories *)

Section CatLaws.

Context {obj : Type} (C : Hom obj).
Context {Eq2C : Eq2 C} {IdC : Id_ C} {CatC : Cat C}.

(** [cat] must have units and be associative. *)

Class CatIdL : Prop :=
  cat_id_l : forall a b (f : C a b), id_ _ >>> f ⩯ f.

Class CatIdR : Prop :=
  cat_id_r : forall a b (f : C a b), f >>> id_ _ ⩯ f.

Class CatAssoc : Prop :=
  cat_assoc : forall a b c d (f : C a b) (g : C b c) (h : C c d),
      (f >>> g) >>> h ⩯ f >>> (g >>> h).

Class Category : Prop := {
  category_cat_id_l :> CatIdL;
  category_cat_id_r :> CatIdR;
  category_cat_assoc :> CatAssoc;
  category_proper_cat :> forall a b c,
      @Proper (C a b -> C b c -> C a c) (eq2 ==> eq2 ==> eq2) cat;
}.

(** *** Initial object *)

(** There is only one morphism between the initial object and
    any other object. *)
Class InitialObject (i : obj) {Initial_i : Initial C i} : Prop :=
  initial_object : forall a (f : C i a), f ⩯ empty.

(** *** Terminal object *)

(** There is a unique morphism from any other object and the terminal object. *)
Class TerminalObject (t : obj) {Terminal_t : Terminal C t} : Prop :=
  terminal_object : forall a (f : C a t), f ⩯ one.

End CatLaws.

Arguments cat_id_l {obj C Eq2C IdC CatC CatIdL} [a b] f.
Arguments cat_id_r {obj C Eq2C IdC CatC CatIdR} [a b] f.
Arguments cat_assoc {obj C Eq2C CatC CatAssoc} [a b c d] f g.
Arguments category_proper_cat {obj C Eq2C IdC CatC Category} [a b c].
Arguments initial_object {obj C Eq2C i Initial_i InitialObject} [a] f.
Arguments terminal_object {obj C Eq2C t Terminal_t TerminalObject} [a] f.

(** Synonym of [initial_object]. *)
Notation unique_initial := initial_object.

(** Synonym of [terminal_object]. *)
Notation unique_terminal := terminal_object.

(** ** Mono-, Epi-, Iso- morphisms *)

(** _Semi-isomorphisms_ are morphisms which compose to the identity.
    If [f >>> f' = id_ _], we also say that [f] is a _section_, or
    _split monomorphism_ and [f'] is a _retraction_, or
    _split epimorphism_.
    _Isomorphisms_ are those that compose _both ways_ to the identity.
 *)

(** The most common example is in the category of functions: sections
    are injective functions, retractions are surjective functions.
    A minor detail to mention regarding that example is that
    traditional function composition is denoted backwards:
    [(f >>> f') x = (f' ∘ f) x = f' (f x)].
 *)

Section SemiIso.

Context {obj : Type} (C : Hom obj).
Context {Eq2C : Eq2 C} {IdC : Id_ C} {CatC : Cat C}.

(** An instance [SemiIso C f f'] means that [f] is a section of
    [f'] in the category [C]. *)
Class SemiIso {a b : obj} (f : C a b) (f' : C b a) : Prop :=
  semi_iso : f >>> f' ⩯ id_ _.

(** The class of isomorphisms *)
Class Iso {a b : obj} (f : C a b) (f' : C b a) : Prop := {
  iso_mono : SemiIso f f';
  iso_epi : SemiIso f' f;
}.

End SemiIso.

#[global] Existing Instance iso_mono.
#[global] Existing Instance iso_epi.
Arguments semi_iso {obj C Eq2C IdC CatC a b} f f' {SemiIso}.

(** ** Opposite *)

Section OppositeCat.

  Context {obj : Type} (C : Hom obj).
  Context {Eq2C : Eq2 C} {IdC : Id_ C} {CatC : Cat C}.

  (* All these opposite instances are prone to trigger loops in instance
     resolution, notably if the category C for which an instance is looked after is a
     meta-variable.
     It also loops easily with the [Fun] since it can interpret it as being [Op]
     too easily.
     I therefore don't declare them [Global] and use [Local Existing Instance] where
     needed. I don't know if there's a better way to go.
   *)
  Instance Eq2_Op : Eq2 (op C) :=
    fun a b => eq2 (C := C).

  Instance Id_Op : Id_ (op C) :=
    id_ (C := C).

  Instance Cat_Op : Cat (op C) :=
    fun a b c f g => cat (C := C) g f.

End OppositeCat.

(** ** Dagger *)

Section DaggerLaws.

  Context {obj : Type} (C : Hom obj).
  Context {Eq2C : Eq2 C} {IdC : Id_ C} {CatC : Cat C}.
  Context {DagC : Dagger C}.

   Instance Dagger_Op : Dagger (op C) :=
    fun a b f => dagger (C := C) f.

  Class DaggerInvolution : Prop :=
    dagger_invol : forall a b (f: C a b), dagger (dagger f) ⩯ f.

  Local Existing Instance Eq2_Op.
  Local Existing Instance Id_Op.
  Local Existing Instance Cat_Op.
  Class DaggerLaws : Prop := {
    dagger_involution :> DaggerInvolution ;
    dagger_functor :> Functor (op C) C id (@dagger obj C _)
   }.

End DaggerLaws.

(** ** Bifunctors *)

Section BifunctorLaws.

Context {obj : Type} (C : Hom obj).
Context {Eq2_C : Eq2 C} {Id_C : Id_ C} {Cat_C : Cat C}.
Context (bif : binop obj).
Context {Bimap_bif : Bimap C bif}.

(** Vertical composition ([bimap]) must be compatible with horizontal
    composition ([cat]). *)

Class BimapId : Prop :=
  bimap_id : forall a b,
    bimap (id_ a) (id_ b) ⩯ id_ (bif a b).

Class BimapCat : Prop :=
  bimap_cat : forall a1 a2 b1 b2 c1 c2
                     (f1 : C a1 b1) (g1 : C b1 c1)
                     (f2 : C a2 b2) (g2 : C b2 c2),
    bimap f1 f2 >>> bimap g1 g2 ⩯ bimap (f1 >>> g1) (f2 >>> g2).

Class Bifunctor : Prop := {
  bifunctor_bimap_id :> BimapId;
  bifunctor_bimap_cat :> BimapCat;
  bifunctor_proper_bimap :> forall a b c d,
      @Proper (C a c -> C b d -> C _ _) (eq2 ==> eq2 ==> eq2) bimap;
}.

End BifunctorLaws.

Arguments bimap_id {obj C Eq2_C Id_C bif Bimap_bif BimapId} a b.
Arguments bimap_cat {obj C Eq2_C Cat_C bif Bimap_bif BimapCat} [_ _ _ _ _ _] f1 g1 f2 g2.

(** ** Coproducts *)

(** These laws capture the essence of sums. *)

Section CoproductLaws.

Context {obj : Type} (C : Hom obj).
Context {Eq2_C : Eq2 C} {Id_C : Id_ C} {Cat_C : Cat C}.
Context (bif : binop obj).
Context {Case_C : Case C bif}
        {Inl_C : Inl C bif}
        {Inr_C : Inr C bif}.

Class CaseInl : Prop :=
  case_inl : forall a b c (f : C a c) (g : C b c),
    inl_ >>> case_ f g ⩯ f.

Class CaseInr : Prop :=
  case_inr : forall a b c (f : C a c) (g : C b c),
    inr_ >>> case_ f g ⩯ g.

(** Uniqueness of coproducts *)
Class CaseUniversal : Prop :=
  case_universal :
    forall a b c (f : C a c) (g : C b c) (fg : C (bif a b) c),
      (inl_ >>> fg ⩯ f) ->
      (inr_ >>> fg ⩯ g) ->
      fg ⩯ case_ f g.

Class Coproduct : Prop := {
  coproduct_case_inl :> CaseInl;
  coproduct_case_inr :> CaseInr;
  coproduct_case_universal :> CaseUniversal;
  coproduct_proper_case :> forall a b c,
      @Proper (C a c -> C b c -> C _ c) (eq2 ==> eq2 ==> eq2) case_
}.

End CoproductLaws.

Arguments case_inl {obj C Eq2_C Cat_C bif Case_C Inl_C CaseInl} [a b c] f g.
Arguments case_inr {obj C Eq2_C Cat_C bif Case_C Inr_C CaseInr} [a b c] f g.
Arguments case_universal {obj C _ _ bif _ _ _ _} [a b c] f g fg.

(** More intuitive names. *)
Notation inl_case := case_inl.
Notation inr_case := case_inr.
(** ** Products *)

(** These laws capture the essence of products. *)

Section ProductLaws.

Context {obj : Type} (C : Hom obj).
Context {Eq2_C : Eq2 C} {Id_C : Id_ C} {Cat_C : Cat C}.
Context (bif : binop obj).
Context {Pair_C : Pair C bif}
        {Fst_C : Fst C bif}
        {Snd_C : Snd C bif}.

Class PairFst : Prop :=
  pair_fst : forall a b c (f : C a b) (g : C a c),
    pair_ f g >>> fst_ ⩯ f.

Class PairSnd : Prop :=
  pair_snd : forall a b c (f : C a b) (g : C a c),
    pair_ f g >>> snd_ ⩯ g.

(** Uniqueness of products *)
Class PairUniversal : Prop :=
  pair_universal :
    forall a b c (f : C c a) (g : C c b) (fg : C c (bif a b)),
      (fg >>> fst_ ⩯ f) ->
      (fg >>> snd_ ⩯ g) ->
      fg ⩯ pair_ f g.

Class Product : Prop := {
  product_pair_fst :> PairFst;
  product_pair_snd :> PairSnd;
  product_pair_universal :> PairUniversal;
  product_proper_pair :> forall a b c,
      @Proper (C c a -> C c b -> C c _) (eq2 ==> eq2 ==> eq2) pair_
}.

End ProductLaws.

Arguments pair_fst {obj C Eq2_C Cat_C bif Pair_C Fst_C PairFst} [a b c] f g.
Arguments pair_snd {obj C Eq2_C Cat_C bif Pair_C Snd_C PairSnd} [a b c] f g.
Arguments pair_universal {obj C _ _ bif _ _ _ _} [a b c] f g fg.

(** Cartesian Closure *)
Section CartesianClosureLaws.

Context {obj : Type} (C : Hom obj).
Context {Eq2_C : Eq2 C} {Id_C : Id_ C} {Cat_C : Cat C}.
Context (ONE : obj)
        {Term_C : Terminal C ONE}.
Context (PROD : binop obj).
Context {Pair_C : Pair C PROD}
        {Fst_C : Fst C PROD}
        {Snd_C : Snd C PROD}.
Context (EXP : binop obj).
Context {Apply_C : Apply C PROD EXP}
        {Curry_C : Curry C PROD EXP}.

Existing Instance Bimap_Product.

Class CurryApply : Prop :=
  curry_apply :
    forall a b c (f : C (PROD c a) b),
      f ⩯ ((@bimap obj C PROD _ _ _ _ _ (curry_ f) (id_ a)) >>> apply_).

Class CartesianClosed : Prop := {
  cartesian_terminal :> TerminalObject _ ONE;
  cartesian_product :> Product _ PROD;
  cartesian_curry_apply :> CurryApply;
  cartesian_proper_curry_ :> forall a b c,
    @Proper (C (PROD c a) b -> C c (EXP a b)) (eq2 ==> eq2) curry_
}.

End CartesianClosureLaws.

Arguments curry_apply {obj C Eq2_C Id_C Cat_C PROD Pair_C Fst_C Snd_C EXP Apply_C Curry_C} _ [a b c] f.

(** ** Monoidal categories *)

Section MonoidalLaws.

Context {obj : Type} (C : Hom obj).
Context {Eq2_C : Eq2 C} {Id_C : Id_ C} {Cat_C : Cat C}.
Context (bif : binop obj).

Context {Bimap_bif : Bimap C bif}.

Context {AssocR_bif : AssocR C bif}.
Context {AssocL_bif : AssocL C bif}.

(** *** Associators and unitors are isomorphisms *)

(** [assoc_r] and [assoc_l] are mutual inverses. *)
Notation AssocIso :=
  (forall a b c, Iso C (assoc_r_ a b c) assoc_l) (only parsing).
(* TODO: should that be a notation? *)

(** [assoc_r] is a split monomorphism, i.e., a left-inverse,
    [assoc_l] is its retraction. *)
Corollary assoc_r_mono {AssocIso_C : AssocIso} : forall a b c,
    assoc_r >>> assoc_l ⩯ id_ (bif (bif a b) c).
Proof.
  intros; apply semi_iso, AssocIso_C.
Qed.

(** [assoc_r] is a split epimorphism, i.e., a right-inverse,
    [assoc_l] is its section. *)
Corollary assoc_l_mono {AssocIso_C : AssocIso} : forall a b c,
    assoc_l >>> assoc_r ⩯ id_ (bif a (bif b c)).
Proof.
  intros; apply semi_iso, AssocIso_C.
Qed.

Context (i : obj).
Context {UnitL_bif  : UnitL  C bif i}.
Context {UnitL'_bif : UnitL' C bif i}.
Context {UnitR_bif  : UnitR  C bif i}.
Context {UnitR'_bif : UnitR' C bif i}.

(** *** Naturality *)

Class UnitLNatural : Prop :=
  natural_unit_l : forall a b (f : C a b),
    bimap (id_ i) f >>> unit_l_ i b ⩯ unit_l_ i a >>> f.

Class UnitL'Natural : Prop :=
  natural_unit_l' : forall a b (f : C a b),
    unit_l'_ i a >>> bimap (id_ i) f ⩯ f >>> unit_l'_ i b.

(** [unit_l] and [unit_l'] are mutual inverses. *)
Notation UnitLIso :=
  (forall a, Iso C (unit_l_ i a) unit_l') (only parsing).

(** [unit_l] is a split monomorphism, i.e., a left-inverse,
    [unit_l'] is its retraction. *)
Corollary unit_l_mono {UnitLIso_C : UnitLIso} : forall a,
    unit_l >>> unit_l' ⩯ id_ (bif i a).
Proof.
  intros; apply semi_iso, UnitLIso_C.
Qed.

(** [unit_l] is a split epimorphism, [unit_l'] is its section. *)
Corollary unit_l_epi {UnitLIso_C : UnitLIso} : forall a,
    unit_l' >>> unit_l ⩯ id_ a.
Proof.
  intros; apply semi_iso, UnitLIso_C.
Qed.

(** [unit_r] and [unit_r'] are mutual inverses. *)
Notation UnitRIso :=
  (forall a, Iso C (unit_r_ i a) unit_r') (only parsing).

Corollary unit_r_mono {UnitRIso_C : UnitRIso} : forall a,
    unit_r >>> unit_r' ⩯ id_ (bif a i).
Proof.
  intros; apply semi_iso, UnitRIso_C.
Qed.

Corollary unit_r_epi {UnitRIso_C : UnitRIso} : forall a,
    unit_r' >>> unit_r ⩯ id_ a.
Proof.
  intros; apply semi_iso, UnitRIso_C.
Qed.

(** *** Coherence laws *)

(** The Triangle Diagram *)
Class AssocRUnit : Prop :=
  assoc_r_unit : forall a b,
    assoc_r >>> bimap (id_ a) unit_l ⩯ bimap unit_r (id_ b).

(** The Pentagon Diagram *)
Class AssocRAssocR : Prop :=
  assoc_r_assoc_r : forall a b c d,
          bimap (@assoc_r _ _ _ _ a b c) (id_ d)
      >>> assoc_r
      >>> bimap (id_ _) assoc_r
    ⩯ assoc_r >>> assoc_r.

Class Monoidal : Prop := {
  monoidal_bifunctor :> Bifunctor C bif;
  monoidal_assoc_iso :> AssocIso;
  monoidal_unit_l_iso :> UnitLIso;
  monoidal_unit_r_iso :> UnitRIso;
  monoidal_unit_l_natural :> UnitLNatural;
  monoidal_unit_l'_natural :> UnitL'Natural;
  monoidal_assoc_r_unit :> AssocRUnit;
  monoidal_assoc_r_assoc_r :> AssocRAssocR;
}.

(** The [assoc_l] variants can be derived by symmetry,
    because [assoc_l] is the inverse of [assoc_r]. *)

Class AssocLUnit : Prop :=
  assoc_l_unit : forall a b,
    assoc_l >>> bimap unit_r (id_ b) ⩯ bimap (id_ a) unit_l.

Class AssocLAssocL : Prop :=
  assoc_l_assoc_l : forall a b c d,
          bimap (id_ a) (@assoc_l _ _ _ _ b c d)
      >>> assoc_l
      >>> bimap assoc_l (id_ _)
    ⩯ assoc_l >>> assoc_l.

End MonoidalLaws.

Arguments assoc_r_mono {obj C Eq2_C Id_C Cat_C bif AssocR_bif AssocL_bif AssocIso_C} a b c.
Arguments assoc_l_mono {obj C Eq2_C Id_C Cat_C bif AssocR_bif AssocL_bif AssocIso_C} a b c.
Arguments unit_l_mono {obj C Eq2_C Id_C Cat_C bif i UnitL_bif UnitL'_bif UnitLIso_C} a.
Arguments unit_l_epi {obj C Eq2_C Id_C Cat_C bif i UnitL_bif UnitL'_bif UnitLIso_C} a.
Arguments unit_r_mono {obj C Eq2_C Id_C Cat_C bif i UnitR_bif UnitR'_bif UnitRIso_C} a.
Arguments unit_r_epi {obj C Eq2_C Id_C Cat_C bif i UnitR_bif UnitR'_bif UnitRIso_C} a.

Arguments assoc_r_unit {obj C Eq2_C Id_C Cat_C bif Bimap_bif AssocR_bif i UnitL_bif UnitR_bif AssocRUnit} a b.
Arguments assoc_r_assoc_r {obj C Eq2_C Id_C Cat_C bif Bimap_bif AssocR_bif AssocRAssocR} a b c d.

Arguments assoc_l_unit {obj C Eq2_C Id_C Cat_C bif Bimap_bif AssocL_bif i UnitL_bif UnitR_bif AssocLUnit} a b.
Arguments assoc_l_assoc_l {obj C Eq2_C Id_C Cat_C bif Bimap_bif AssocL_bif AssocLAssocL} a b c d.

(** ** Symmetric monoidal categories *)

Section SymmetricLaws.

Context {obj : Type} (C : Hom obj).
Context {Eq2_C : Eq2 C} {Id_C : Id_ C} {Cat_C : Cat C}.
Context (bif : binop obj).
Context {Bimap_bif : Bimap C bif}.
Context {Swap_bif : Swap C bif}.

(** [swap] is an involution *)
Notation SwapInvolutive :=
  (forall a b, SemiIso C (swap_ a b) swap) (only parsing).

Corollary swap_involutive {SwapInvolutive_C : SwapInvolutive}
  : forall a b, swap >>> swap ⩯ id_ (bif a b).
Proof.
  intros; apply semi_iso, SwapInvolutive_C.
Qed.

Context (i : obj).
Context {UnitL_i  : UnitL  C bif i}.
Context {UnitL'_i : UnitL' C bif i}.
Context {UnitR_i  : UnitR  C bif i}.
Context {UnitR'_i : UnitR' C bif i}.

(** Coherence between [swap] and unitors. *)
Class SwapUnitL : Prop :=
  swap_unit_l : forall a, swap >>> unit_l ⩯ unit_r_ _ a.

Context {AssocR_bif : AssocR C bif}.
Context {AssocL_bif : AssocL C bif}.

(** Coherence between [swap] and associators. *)
Class SwapAssocR : Prop :=
  swap_assoc_r : forall a b c,
    @assoc_r _ _ _ _ a _ _ >>> swap >>> assoc_r
  ⩯ bimap swap (id_ c) >>> assoc_r >>> bimap (id_ b) swap.

(** Symmetric monoidal category. *)
Class SymMonoidal : Prop := {
  symmetric_monoidal : Monoidal C bif i;
  symmetric_swap_involutive : SwapInvolutive;
  symmetric_swap_unit_l : SwapUnitL;
  symmetric_swap_assoc_r : SwapAssocR;
}.
(* The name [Symmetric] is taken by [Setoid]. *)

Class SwapAssocL : Prop :=
  swap_assoc_l : forall a b c,
    @assoc_l _ _ _ _ _ _ c >>> swap >>> assoc_l
  ⩯ bimap (id_ a) swap >>> assoc_l >>> bimap swap (id_ b).

End SymmetricLaws.

Arguments swap_involutive {obj C Eq2_C Id_C Cat_C bif Swap_bif SwapInvolutive_C} a b.
Arguments swap_unit_l {obj C Eq2_C Cat_C bif Swap_bif i UnitL_i UnitR_i SwapUnitL} a.
Arguments swap_assoc_r {obj C Eq2_C Id_C Cat_C bif Bimap_bif Swap_bif AssocR_bif  SwapAssocR} a b c.
Arguments swap_assoc_l {obj C Eq2_C Id_C Cat_C bif Bimap_bif Swap_bif AssocL_bif  SwapAssocL} a b c.

Section IterationLaws.

Context {obj : Type} (C : Hom obj).
Context {Eq2_C : Eq2 C} {Id_C : Id_ C} {Cat_C : Cat C}.
Context (bif : binop obj).
Context {Case_C : Case C bif}.
Context {Inl_C : Inl C bif}.
Context {Inr_C : Inr C bif}.
Context {Iter_C : Iter C bif}.

(** The loop operation satisfies a fixed point equation. *)
Class IterUnfold : Prop :=
  iter_unfold : forall a b (f : C a (bif a b)),
    iter f ⩯ f >>> case_ (iter f) (id_ b).

(** Naturality in the output (in [b], with [C a (bif a b) -> C a b]).
    Also known as "parameter identity". *)
Class IterNatural : Prop :=
  iter_natural : forall a b c (f : C a (bif a b)) (g : C b c),
    iter f >>> g ⩯ iter (f >>> bimap (id_ _) g).

(** Dinaturality in the accumulator (in [a], with [C a (bif a b) -> C a b]).
    Also known as "composition identity". *)
Class IterDinatural : Prop :=
  iter_dinatural : forall a b c (f : C a (bif b c)) (g : C b (bif a c)),
                   iter (f >>> case_ g inr_)
    ⩯ f >>> case_ (iter (g >>> case_ f inr_)) (id_ _).
(** TODO: provable from the others + uniformity? *)

(** Flatten nested loops. Also known as "double dagger identity". *)
Class IterCodiagonal : Prop :=
  iter_codiagonal : forall a b (f : C a (bif a (bif a b))),
    iter (iter f) ⩯ iter (f >>> case_ inl_ (id_ _)).

(* TODO: also define uniformity, requires a "purity" assumption. *)

Class Iterative : Prop :=
  { iterative_unfold :> IterUnfold
  ; iterative_natural :> IterNatural
  ; iterative_dinatural :> IterDinatural
  ; iterative_codiagonal :> IterCodiagonal
  ; iterative_proper_iter
      :> forall a b, @Proper (C a (bif a b) -> C a b) (eq2 ==> eq2) iter
  }.

(** Also called Bekic identity *)
Definition IterPairing : Prop :=
  forall a b c (f : C a (bif (bif a b) c)) (g : C b (bif (bif a b) c)),
    let h : C b (bif b c)
        := g >>> assoc_r >>> case_ (iter (f >>> assoc_r)) (id_ _)
    in
      iter (case_ f g)
    ⩯ iter (case_ (iter (f >>> assoc_r)
                         >>> case_ (iter h) (id_ _) >>> inr_)
                      (h >>> bimap inr_ (id_ _))).

End IterationLaws.

Arguments iter_unfold {obj C Eq2_C Id_C Cat_C bif Case_C Iter_C IterUnfold} [a b] f.
Arguments iter_natural {obj C Eq2_C Id_C Cat_C bif Case_C Inl_C Inr_C Iter_C IterNatural} [a b c] f.
Arguments iter_dinatural {obj C Eq2_C Id_C Cat_C bif Case_C Inr_C Iter_C IterDinatural} [a b c] f.
Arguments iter_codiagonal {obj C Eq2_C Id_C Cat_C bif Case_C Inl_C Iter_C IterCodiagonal} [a b] f.
Arguments iterative_proper_iter {obj C Eq2_C Id_C Cat_C bif Case_C Inl_C Inr_C Iter_C Iterative}.