Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.lib.Coqlib.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.TheoryOfSequentCalculus.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.

Module ModalLogic_Pub.

Inductive L_Pub : Type :=
  |atomp : nat -> L_Pub
  |falsep : L_Pub
  |impp : L_Pub -> L_Pub -> L_Pub
  |boxa : L_Pub -> L_Pub
  |boxb : L_Pub -> L_Pub
  |boxc : L_Pub -> L_Pub
  |A0 : L_Pub
  |B0 : L_Pub
  |C0 : L_Pub.

Definition negp (l : L_Pub) :=
  impp l falsep.
Definition orp (l1 l2 : L_Pub) :=
  impp (negp l1) l2.
Definition andp (l1 l2 : L_Pub) :=
  negp (orp (negp l1) (negp l2)).
Definition iffp (l1 l2 : L_Pub) :=
  andp (impp l1 l2)(impp l2 l1).
Definition truep := negp falsep.
Definition diamonda (l : L_Pub) :=
  negp (boxa (negp l)).
Definition diamondb (l : L_Pub) :=
  negp (boxb (negp l)).
Definition diamondc (l : L_Pub) :=
  negp (boxc (negp l)).

Notation "~~ x" := (negp x) (at level 35).
Notation "x --> y" := (impp x y)(at level 55, right associativity).
Notation "x || y" := (orp x y)(at level 50, left associativity).
Notation "x && y" := (andp x y)(at level 40, left associativity).
Notation "x <--> y" := (iffp x y) (at level 60, no associativity).
Reserved Notation "|-- P " (at level 71, no associativity).

Inductive T_Pub : L_Pub -> Prop:=
  | A_P1: forall p q, |-- (p --> (q --> p))
  | A_P2: forall p q r, |-- ((p --> q --> r) --> (p --> q) --> (p --> r))
  | A_P3: forall p q, |-- (~~p --> q) --> ((~~p --> ~~q) --> p)
  (*代入规则在Coq中总是被承认的*)
  | MP: forall a b, |-- (a --> b) -> |--a -> |-- b

  | K_AXIOM_A: forall p q, |-- boxa (p --> q) --> (boxa p --> boxa q)
  | T_AXIOM_A: forall p, |-- (boxa p) --> p
  | N_RULE_A: forall a, |-- a -> |-- boxa a
  | PUB_ASSERT_A: |-- boxa A0 || boxa (~~A0)

  | K_AXIOM_B: forall p q, |-- boxb (p --> q) --> (boxb p --> boxb q)
  | T_AXIOM_B: forall p, |-- (boxb p) --> p
  | N_RULE_B: forall a, |-- a -> |-- boxb a
  | PUB_ASSERT_B: |-- boxb B0 || boxb (~~B0)

  | K_AXIOM_C: forall p q, |-- boxc (p --> q) --> (boxc p --> boxc q)
  | T_AXIOM_C: forall p, |-- (boxc p) --> p
  | N_RULE_C: forall a, |-- a -> |-- boxc a
  | PUB_ASSERT_C: |-- boxc C0 || boxc (~~C0)
where "|-- P" := (T_Pub P).
(* in this Module, we always try to use a/b/c... when talking
abort rule, and use p/q/r... when talking abort axiom or lemma*)

Instance MLPubL: Language := {|
  expr := ModalLogic_Pub.L_Pub
|}.

Instance MLPubminL: MinimumLanguage MLPubL := {|
  Logic.MinimumLogic.Syntax.impp := ModalLogic_Pub.impp
|}.

Instance MLPubpL: PropositionalLanguage MLPubL := {|
  Logic.PropositionalLogic.Syntax.andp := ModalLogic_Pub.andp;
  Logic.PropositionalLogic.Syntax.orp := ModalLogic_Pub.orp;
  Logic.PropositionalLogic.Syntax.falsep := ModalLogic_Pub.falsep
|}.

Instance MLPubGamma: Provable MLPubL := {|
  provable := ModalLogic_Pub.T_Pub
|}.

Instance MLPubminAX: MinimumAxiomatization MLPubL MLPubGamma.
Proof.
  constructor.
  + apply ModalLogic_Pub.MP.
  + apply ModalLogic_Pub.A_P1.
  + apply ModalLogic_Pub.A_P2.
Qed.

Instance T_Pub_impp_rewrite: RewriteRelation (fun x y => |-- x --> y).
Qed.
Instance T_Pub_impp_refl : Reflexive (fun x y => |-- impp x y).
Proof.
  pose proof provable_impp_refl_instance.
  apply H.
Qed.
Instance T_Pub_proper_impp : Proper ((fun x y => |-- impp x y) ==> Basics.impl) T_Pub.
Proof.
  pose proof provable_proper_impp.
  apply H.
Qed.
Instance impp_proper_impp : Proper ((fun x y => |-- impp x y) --> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) impp.
Proof.
  pose proof impp_proper_impp.
  apply H.
Qed.

Lemma RG : forall a b, |-- a -> |-- b --> a.
Proof.
  intros.
  pose proof A_P1 a b.
  pose proof MP _ _ H0 H.
  apply H1. Qed.

Lemma impp_refl: forall (p: L_Pub), |-- p --> p.
Proof.
  intros.
  pose proof provable_impp_refl p.
  apply H.
  Qed.

Lemma impp_substitute: forall p q, |-- p --> (p --> q) --> q.
Proof.
  intros.
  pose proof aux_minimun_theorem02 p q.
  apply H. Qed.

Lemma impp_trans: forall (p q r: L_Pub), |--  (q --> r) --> (p --> q) --> (p --> r).
Proof.
  intros.
  pose proof aux_minimun_theorem00 p q r.
  apply H. Qed.

Lemma RS_pre: forall (a b c: L_Pub), |-- (b --> c) -> |-- (a --> b) --> (a --> c).
Proof.
  intros a b c.
  pose proof aux_minimun_rule01 b c a.
  apply H. Qed.

Lemma RS: forall (a b c: L_Pub), |-- (b --> c) -> |-- (a --> b) -> |--(a --> c).
Proof.
  intros.
  pose proof RS_pre a b c H.
  pose proof MP _ _ H1 H0.
  apply H2. Qed.

Lemma impp_trans_infer1: forall p q r s, |-- (r --> s) --> (p --> q --> r) --> (p --> q --> s).
Proof.
  intros.
  pose proof impp_trans q r s.
  pose proof impp_trans p (q --> r) (q --> s).
  pose proof RS _ _ _ H0 H.
  apply H1. Qed.

Lemma RS_infer1: forall a b c d, |-- c --> d -> |-- a --> b --> c -> |-- a --> b --> d.
Proof.
  intros.
  pose proof impp_trans_infer1 a b c d.
  pose proof MP _ _ H1 H.
  pose proof MP _ _ H2 H0.
  apply H3. Qed.

Lemma impp_switch: forall p q r, |-- (p --> (q --> r)) --> (q --> (p --> r)).
Proof.
  intros.
  pose proof provable_impp_arg_switch p q r.
  apply H. Qed.

Lemma RIS: forall a b c, |-- a --> b --> c -> |-- b --> a --> c.
Proof.
  intros.
  pose proof impp_switch a b c.
  pose proof MP _ _ H0 H.
  apply H1. Qed.

Lemma RIS_infer1: forall a b c d, |-- a --> b --> c --> d -> |-- c --> a --> b --> d.
Proof.
  intros.
  pose proof impp_switch b c d.
  pose proof impp_switch a c (b --> d).
  rewrite H0 in H.
  pose proof MP _ _ H1 H.
  apply H2. Qed.

Lemma negp_double1: forall p, |-- ~~(~~p) --> p.
Proof.
  intros.
  pose proof A_P3 p (~~p).
  pose proof impp_refl (~~p).
  pose proof MP _ _ H H0.
  pose proof A_P1 (~~(~~p)) (~~p).
  pose proof RS _ _ _ H1 H2.
  apply H3. Qed.

Lemma negp_double2: forall p, |-- p --> ~~(~~p).
Proof.
  intros.
  unfold negp.
  pose proof impp_substitute p falsep.
  apply H. Qed.

Lemma impp_comm1: forall p q, |--(~~p --> q) --> (~~q --> p).
Proof.
  intros.
  pose proof A_P1 (~~q) (~~p).
  pose proof A_P3 p (~~q).
  pose proof RS _ _ _ H0 H.
  pose proof RIS _ _ _ H1.
  pose proof negp_double2 q.
  rewrite -> H3 at 1.
  apply H2. Qed.

Lemma impp_comm2: forall p q, |--(p --> ~~q) --> (q --> ~~p).
Proof.
  intros.
  pose proof impp_comm1 (~~p) (~~q).
  pose proof negp_double1 p.
  pose proof negp_double2 q.
  rewrite <- H0 at 1.
  rewrite -> H1 at 2.
  apply H. Qed.

Lemma impp_comm3: forall p q, |--(p --> q) --> (~~q --> ~~p).
Proof.
  intros.
  pose proof impp_comm2 p (~~q).
  pose proof negp_double2 q.
  rewrite H0 at 1.
  apply H. Qed.

Lemma impp_reduc: forall p q, |-- (p --> q) --> (~~p --> q) --> q.
Proof.
  intros.
  pose proof A_P3 q (~~p).
  pose proof impp_comm3 p q.
  rewrite H0.
  pose proof impp_comm1 p q.
  rewrite H1.
  pose proof negp_double2 p.
  rewrite H2 at 2.
  apply H. Qed.

Lemma DS: forall a b, |-- a --> a --> b -> |-- a --> b.
Proof.
  intros.
  pose proof aux_minimun_theorem04 a b.
  pose proof MP _ _ H0 H.
  apply H1. Qed.

Lemma orp_intros1 : forall p q, |-- p --> (p || q).
Proof.
  unfold orp.
  intros.
  pose proof A_P1 p (~~q).
  pose proof impp_comm1 q p.
  pose proof RS _ _ _ H0 H.
  apply H1. Qed.

Lemma orp_intros2 : forall p q, |-- q --> (p || q).
Proof.
  unfold orp.
  intros.
  pose proof A_P1 q (~~p).
  apply H. Qed.

Lemma orp_elim : forall p q r, |-- (p --> r) --> (q --> r) --> ((p || q) --> r).
Proof.
  unfold orp.
  intros.
  pose proof impp_trans (~~p) q r.
  pose proof impp_reduc p r.
  pose proof RIS _ _ _ H0.
  pose proof RS_infer1 _ _ _ _ H1 H.
  pose proof RIS_infer1 _ _ _ _ H2.
  apply H3. Qed.

Lemma andp_intros : forall p q, |-- p --> (q --> (p && q)).
Proof.
  unfold andp.
  unfold orp.
  intros.
  pose proof impp_substitute p (~~q).
  pose proof impp_comm2 (p --> ~~ q) q.
  pose proof RS _ _ _ H0 H.
  pose proof impp_comm2 q (p --> ~~ q).
  rewrite H2 in H1.
  pose proof negp_double2 p.
  rewrite H3 in H1 at 2.
  pose proof impp_comm2 (~~ (~~ p) --> ~~ q) q.
  rewrite H4 in H1.
  apply H1. Qed.

Lemma andp_elim1 : forall p q,  |-- (p && q) --> p.
Proof.
  unfold andp.
  unfold orp.
  intros.
  pose proof impp_comm1 p (~~ (~~ p) --> ~~ q).
  pose proof orp_intros1 (~~p) (~~q). unfold orp in H0.
  pose proof MP _ _ H H0.
  apply H1. Qed.

Lemma andp_elim2 : forall p q, |-- (p && q) --> q.
Proof.
  unfold andp.
  unfold orp.
  intros.
  pose proof A_P1 (~~q) (~~ (~~ p)).
  pose proof impp_comm1 q (~~ (~~ p) --> ~~ q).
  pose proof MP _ _ H0 H.
  apply H1. Qed.

Lemma falsep_elim : forall p, |-- (falsep --> p).
Proof.
  intros.
  pose proof A_P3 p falsep.
  unfold negp in H.
  pose proof impp_refl falsep.
  pose proof RG _ (p --> falsep) H0.
  pose proof RG _ falsep H1.
  pose proof RIS _ _ _ H1.
  rewrite <- H3 in H.
  rewrite <- H2 in H.
  pose proof DS _ _ H.
  apply H4. Qed.

Instance MLPubipGamma: IntuitionisticPropositionalLogic MLPubL MLPubGamma.
Proof.
  constructor.
  + apply ModalLogic_Pub.andp_intros.
  + apply ModalLogic_Pub.andp_elim1.
  + apply ModalLogic_Pub.andp_elim2.
  + apply ModalLogic_Pub.orp_intros1.
  + apply ModalLogic_Pub.orp_intros2.
  + apply ModalLogic_Pub.orp_elim.
  + apply ModalLogic_Pub.falsep_elim.
Qed.

Lemma excluded_middle : forall p, |-- p || ~~ p.
Proof.
  intros.
  unfold orp.
  pose proof impp_refl (~~p).
  apply H. Qed.

Instance MLPubcpGamma: ClassicalPropositionalLogic MLPubL MLPubGamma.
Proof.
  constructor.
  + apply ModalLogic_Pub.excluded_middle.
Qed.

Lemma weak_excluded_middle: forall p, |-- ~~ p || ~~ ~~p.
Proof.
  intros.
  pose proof excluded_middle (~~p).
  apply H.
Qed.

Instance MLPubdmpGamma: DeMorganPropositionalLogic MLPubL MLPubGamma.
Proof.
  constructor.
  + apply ModalLogic_Pub.weak_excluded_middle.
Qed.

Instance T_Pub_iffp_rewrite: RewriteRelation (fun x y => |-- x <--> y).
Qed.
Instance T_Pub_iffp_equiv: Equivalence (fun x y => |-- x <--> y).
Proof.
  pose proof provable_iffp_equiv.
  apply H.
Qed.
Instance T_Pub_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> iff) T_Pub.
Proof.
  pose proof provable_proper_iffp.
  apply H.
Qed.
Instance impp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) impp.
Proof.
  pose proof impp_proper_iffp.
  apply H.
Qed.
Instance andp_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) andp.
Proof.
  pose proof andp_proper_impp.
  apply H.
Qed.
Instance orp_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) orp.
Proof.
  pose proof orp_proper_impp.
  apply H.
Qed.
Instance negp_proper_impp: Proper ((fun x y => |-- impp x y) --> (fun x y => |-- impp x y)) negp.
Proof.
  pose proof negp_proper_impp.
  apply H.
Qed.
Instance andp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) andp.
Proof.
  pose proof andp_proper_iffp.
  apply H.
Qed.
Instance orp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) orp.
Proof.
  pose proof orp_proper_iffp.
  apply H.
Qed.
Instance iffp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) iffp.
Proof.
  pose proof iffp_proper_iffp.
  apply H.
Qed.
Instance negp_proper_iffp: Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) negp.
Proof.
  pose proof negp_proper_iffp.
  apply H.
Qed.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Class PubBaseLanguage (L: Language): Type := {
  boxp : expr -> expr;
  P0 : expr
}.

Definition diamondp {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {pbL: PubBaseLanguage L} (p : expr): expr :=
  Syntax.negp (boxp (Syntax.negp p)).

Class PubBaseAxiomatization (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {pbL: PubBaseLanguage L} (Gamma: Provable L) {minAX: MinimumAxiomatization L Gamma} {ipGamma: IntuitionisticPropositionalLogic L Gamma} {cpGamma: ClassicalPropositionalLogic L Gamma} := {
  K_AXIOM: forall p q, |-- boxp (p --> q) --> (boxp p --> boxp q);
  T_AXIOM: forall p, |-- (boxp p) --> p;
  N_RULE: forall a, |-- a -> |-- boxp a;
  PUB_ASSERT: |-- boxp P0 || boxp (~~P0)
}.

Section RewriteClass_Pub.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {pbL: PubBaseLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {cpGamma: ClassicalPropositionalLogic L Gamma}
        {dmpAX: DeMorganPropositionalLogic L Gamma}
        {pbAX: PubBaseAxiomatization L Gamma}.

Instance boxp_proper_impp : Proper ((fun x y => |-- Syntax.impp x y) ==> (fun x y => |-- Syntax.impp x y)) boxp.
Proof.
  hnf; intros x1 x2 ?.
  apply N_RULE in H.
  pose proof K_AXIOM x1 x2.
  pose proof modus_ponens _ _ H0 H.
  apply H1. Qed.

Instance boxp_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) boxp.
Proof.
  hnf; intros x1 x2 ?.
  unfold iffp in H.
  pose proof Intuitionistic.andp_elim1 (x1 --> x2) (x2 --> x1).
  pose proof modus_ponens _ _ H0 H.
  pose proof Intuitionistic.andp_elim2 (x1 --> x2) (x2 --> x1).
  pose proof modus_ponens _ _ H2 H.
  pose proof boxp_proper_impp x1 x2. hnf in H4.
  pose proof boxp_proper_impp x2 x1. hnf in H5.
  apply H4 in H1.
  apply H5 in H3.
  pose proof Intuitionistic.andp_intros (boxp x1 --> boxp x2) (boxp x2 --> boxp x1).
  pose proof modus_ponens _ _ H6 H1.
  pose proof modus_ponens _ _ H7 H3.
  unfold iffp.
  apply H8. Qed.

End RewriteClass_Pub.

Existing Instances boxp_proper_impp boxp_proper_iffp.

Section LemmaFromPubBaseAxiomatization.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {pbL: PubBaseLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {cpGamma: ClassicalPropositionalLogic L Gamma}
        {dmpAX: DeMorganPropositionalLogic L Gamma}
        {pbAX: PubBaseAxiomatization L Gamma}.

Lemma boxp_impp_refl: forall (p: expr), |-- (boxp (p --> p)).
Proof.
  intros.
  pose proof provable_impp_refl p as H1.
  pose proof N_RULE _ H1.
  apply H.
  Qed.

Lemma RK: forall (p q: expr), |-- p --> q -> |-- boxp p --> boxp q.
Proof.
  intros.
  pose proof N_RULE _ H.
  pose proof K_AXIOM p q.
  rewrite H1 in H0.
  apply H0. Qed.

Lemma T_AXIOM_infer1: forall (p: expr), |-- ~~p --> ~~ (boxp p).
Proof.
  intros.
  pose proof T_AXIOM p.
  pose proof contrapositivePP p (boxp p).
  pose proof modus_ponens _ _ H0 H.
  apply H1. Qed.

Lemma falsep_truthp_intros: forall (p q: expr), |-- (~~p) --> q --> ~~(p && q).
Proof.
  intros.
  pose proof Intuitionistic.andp_elim1 p q.
  pose proof contrapositivePP p (p && q).
  rewrite H0 in H.
  pose proof aux_minimun_rule00 _ q H.
  pose proof provable_impp_arg_switch q (~~p) (~~ (p && q)).
  rewrite H2 in H1.
  apply H1. Qed.

Lemma impp2orp_infer1: forall (p q: expr), |-- (p || q) --> (~~p --> q).
Proof.
  intros.
  pose proof impp2orp (~~p) q.
  pose proof double_negp p.
  rewrite H0 in H.
  rewrite H.
  pose proof provable_impp_refl (p || q).
  apply H1. Qed.

Lemma P_impp_boxp1: |-- P0 --> boxp P0.
Proof.
  pose proof PUB_ASSERT.
  pose proof impp2orp_infer1 (boxp P0) (boxp (~~P0)).
  rewrite H0 in H.
  pose proof T_AXIOM (~~P0).
  rewrite H1 in H.
  pose proof contrapositiveNP (~~P0) (boxp P0).
  rewrite H2 in H.
  pose proof double_negp_intros P0.
  rewrite <- H3 in H.
  apply H. Qed.

Lemma boxp_andp_elim: forall (p q: expr), |-- boxp(p && q) --> (boxp p && boxp q).
Proof.
  intros.
  pose proof Intuitionistic.andp_elim1 p q.
  pose proof Intuitionistic.andp_elim2 p q.
  pose proof RK _ _ H.
  pose proof RK _ _ H0.
  pose proof solve_impp_andp _ _ _ H1 H2.
  apply H3. Qed.

Lemma boxp_andp_intros: forall (p q: expr), |-- (boxp p && boxp q) --> boxp(p && q).
Proof.
  intros.
  pose proof Intuitionistic.andp_intros p q.
  pose proof RK _ _ H.
  pose proof K_AXIOM q (p && q).
  rewrite -> H1 in H0.
  pose proof Intuitionistic.impp_curry_uncurry (boxp p) (boxp q) (boxp (p && q)).
  rewrite H2 in H0.
  apply H0. Qed.

Lemma boxp_orp_intros: forall (p q: expr), |-- (boxp p || boxp q) --> boxp(p || q).
Proof.
  intros.
  pose proof Intuitionistic.orp_intros1 p q.
  pose proof RK _ _ H.
  pose proof Intuitionistic.orp_intros2 p q.
  pose proof RK _ _ H1.
  pose proof solve_orp_impp _ _ _ H0 H2.
  apply H3. Qed.

Lemma diamondp_boxp_intros: forall (p q: expr), |-- diamondp q --> boxp p --> diamondp (p && q).
Proof.
  intros.
  pose proof Intuitionistic.andp_intros p q.
  pose proof contrapositivePP (p&&q) q.
  rewrite H0 in H.
  pose proof RK _ _ H.
  pose proof K_AXIOM (~~ (p && q)) (~~q).
  rewrite H2 in H1.
  pose proof contrapositivePP (boxp (~~ q)) (boxp (~~ (p && q))).
  rewrite H3 in H1.
  pose proof provable_impp_arg_switch (boxp p) (~~ boxp (~~ q)) (~~ boxp (~~ (p && q))).
  rewrite H4 in H1.
  unfold diamondp.
  apply H1. Qed.

Lemma basic_situation1: forall (A B: expr), |-- ((diamondp B) && (diamondp (~~B))) --> boxp A --> (~~boxp (A&&B)).
Proof.
  intros.
  pose proof falsep_truthp_intros (boxp B) (boxp A).
  pose proof boxp_andp_elim B A.
  rewrite <- H0 in H.
  pose proof aux_minimun_rule00 _ (~~ boxp (~~B)) H.
  pose proof impp_curry (~~ boxp (~~ B)) (~~ boxp B) (boxp A --> ~~ boxp (B && A)).
  rewrite H2 in H1.
  pose proof andp_comm A B.
  rewrite <- H3 in H1.
  unfold diamondp.
  pose proof double_negp B.
  rewrite <- H4 in H1 at 2.
  apply H1. Qed.

Lemma basic_situation2: forall (A B: expr), |-- ((diamondp B) && (diamondp (~~B))) --> boxp A --> (~~boxp (~~(A&&B))).
Proof.
  intros.
  pose proof diamondp_boxp_intros A B.
  rewrite <- H.
  pose proof Intuitionistic.andp_elim1 (diamondp B) (diamondp (~~B)).
  apply H0. Qed.

Lemma andp_impp_orp: forall (p q: expr), |-- (p && q) --> (p || q).
Proof.
  intros.
  pose proof Intuitionistic.andp_elim1 p q.
  pose proof Intuitionistic.orp_intros1 p q.
  rewrite H0 in H at 2.
  apply H. Qed.

Lemma diamondp_negp_elim: forall (p q: expr), |-- diamondp (p && ~~q) && diamondp (~~p && q) && diamondp (~~p && ~~q) --> diamondp(~~(p && q)).
Proof.
  intros.
  unfold diamondp.
  pose proof andp_impp_orp p q.
  pose proof RK _ _ H.
  pose proof demorgan_negp_andp (~~p) (~~q).
  pose proof double_negp p.
  rewrite -> H2 in H1.
  pose proof double_negp q.
  rewrite -> H3 in H1.
  rewrite <- H1 in H0.
  pose proof double_negp (p && q).
  rewrite <- H4 in H0.
  rewrite <- H0.
  pose proof Minimum.provable_impp_refl (~~ boxp (~~ (~~ (p && q)))).
  pose proof aux_minimun_rule00 _ (~~ boxp (~~ (p && ~~ q)) && ~~ boxp (~~ (~~ p && q))) H5.
  pose proof impp_curry (~~ boxp (~~ (p && ~~ q)) && ~~ boxp (~~ (~~ p && q))) (~~ boxp (~~ (~~ (p && q)))) (~~ boxp (~~ (~~ (p && q)))).
  rewrite -> H7 in H6.
  apply H6. Qed.

Lemma diamondp_negp_elim_infer1: forall (p q: expr), |-- diamondp (p && q) && diamondp (p && ~~q) && diamondp (~~p && q) && diamondp (~~p && ~~q) --> diamondp (p && q) && diamondp(~~(p && q)).
Proof.
  intros.
  pose proof andp_assoc (diamondp (p && q) && diamondp (p && ~~ q)) (diamondp (~~ p && q)) (diamondp (~~ p && ~~ q)).
  rewrite -> H.
  pose proof andp_assoc (diamondp (p && q)) (diamondp (p && ~~ q)) (diamondp (~~ p && q) && diamondp (~~ p && ~~ q)).
  rewrite -> H0.
  pose proof andp_assoc (diamondp (p && ~~ q)) (diamondp (~~ p && q)) (diamondp (~~ p && ~~ q)).
  rewrite <- H1.
  pose proof diamondp_negp_elim p q.
  rewrite -> H2.
  pose proof Minimum.provable_impp_refl (diamondp (p && q) && diamondp (~~ (p && q))).
  apply H3. Qed.

Lemma andp_intros_infer1: forall (A B C: expr), |-- ~~A --> ~~(A&&B&&C).
Proof.
  intros.
  pose proof Intuitionistic.andp_elim1 A (B&&C).
  pose proof contrapositivePP A (A && (B && C)).
  pose proof modus_ponens _ _ H0 H.
  pose proof andp_assoc A B C.
  rewrite H2.
  apply H1. Qed.

Lemma P_impp_boxp2: |-- ~~P0 --> boxp (~~P0).
Proof.
  pose proof PUB_ASSERT.
  pose proof orp_comm (boxp P0) (boxp (~~ P0)).
  rewrite H0 in H.
  pose proof impp2orp_infer1 (boxp (~~ P0)) (boxp P0).
  rewrite H1 in H.
  pose proof T_AXIOM P0.
  rewrite H2 in H.
  pose proof contrapositiveNP P0 (boxp (~~ P0)).
  rewrite H3 in H.
  apply H. Qed.

Lemma boxp_orp_intros_infer1: forall (p q: expr), |-- boxp p --> boxp (p || ~~q).
Proof.
  intros.
  pose proof boxp_orp_intros p (~~q).
  pose proof Intuitionistic.orp_intros1 (boxp p) (boxp (~~q)).
  rewrite <- H0 in H.
  apply H. Qed.

Lemma diamondp_andp_minus: forall (p q: expr), |-- (diamondp (p && q) && diamondp (p && ~~q) && diamondp (~~p && q) && diamondp (~~p && ~~q)) --> boxp p --> diamondp q && diamondp (~~ q).
Proof.
  intros.
  unfold diamondp.
  pose proof boxp_orp_intros_infer1 p q.
  pose proof aux_minimun_rule00 _ (~~ (~~ boxp (~~ q) && ~~ boxp (~~ (~~ q)))) H.
  pose proof provable_impp_arg_switch (~~ (~~ boxp (~~ q) && ~~ boxp (~~ (~~ q)))) (boxp p) (boxp (p || ~~ q)).
  rewrite -> H1 in H0.
  pose proof contrapositiveNP (boxp (p || ~~ q)) (~~ boxp (~~ q) && ~~ boxp (~~ (~~ q))).
  rewrite -> H2 in H0.
  pose proof provable_impp_arg_switch (boxp p) (~~ boxp (p || ~~ q)) (~~ boxp (~~ q) && ~~ boxp (~~ (~~ q))).
  rewrite -> H3 in H0.
  pose proof demorgan_negp_andp (~~p) q.
  pose proof double_negp p.
  rewrite -> H5 in H4.
  rewrite <- H4 in H0.
  pose proof Intuitionistic.andp_elim1 (~~ boxp (~~ (~~ p && q))) (~~ boxp (~~ (~~ p && ~~ q))).
  rewrite <- H6 in H0.
  pose proof aux_minimun_rule00 _ (~~ boxp (~~ (p && q)) && ~~ boxp (~~ (p && ~~ q))) H0.
  pose proof impp_curry (~~ boxp (~~ (p && q)) && ~~ boxp (~~ (p && ~~ q))) (~~ boxp (~~ (~~ p && q)) && ~~ boxp (~~ (~~ p && ~~ q))) (boxp p --> ~~ boxp (~~ q) && ~~ boxp (~~ (~~ q))).
  rewrite -> H8 in H7.
  pose proof andp_assoc (~~ boxp (~~ (p && q)) && ~~ boxp (~~ (p && ~~ q))) (~~ boxp (~~ (~~ p && q))) (~~ boxp (~~ (~~ p && ~~ q))).
  rewrite <- H9 in H7.
  apply H7. Qed.

Lemma andp_dup_infer1: forall (p q r: expr), |-- (p&&q&&r) --> (p&&q&&q&&r).
Proof.
  intros.
  pose proof andp_dup q.
  rewrite <- H at 1.
  pose proof andp_assoc p q q.
  rewrite <- H0.
  pose proof Minimum.provable_impp_refl (p && q && q && r).
  apply H1. Qed.

Lemma andp_assoc_infer1: forall (p q r s: expr), |-- (p&&q) --> (q&&r) --> s -> |-- (p --> q --> r --> s).
Proof.
  intros.
  pose proof Intuitionistic.impp_curry_uncurry p q (r-->s).
  pose proof Intuitionistic.impp_curry_uncurry (p && q) r s.
  rewrite -> H1 in H0.
  rewrite H0.
  pose proof andp_dup_infer1 p q r.
  rewrite -> H2.
  pose proof Intuitionistic.impp_curry_uncurry (p && q) (q && r) s.
  pose proof andp_assoc (p&&q) q r.
  rewrite -> H4.
  rewrite <- H3.
  apply H. Qed.

Lemma andp_intros_infer2: forall (A B C: expr), |-- A --> B --> C --> (A&&B&&C).
Proof.
  intros.
  pose proof Intuitionistic.andp_intros (A&&B) C.
  rewrite <- H.
  pose proof Intuitionistic.andp_intros A B.
  apply H0. Qed.

Lemma boxp_one_unknown1: forall (B C: expr), |--(diamondp (B && C) && diamondp (B && ~~C) && diamondp (~~B && C) && diamondp (~~B && ~~C)) --> P0 --> (~~boxp (P0&&B&&C)).
Proof.
  intros.
  pose proof basic_situation1 P0 (B&&C).
  pose proof P_impp_boxp1.
  rewrite <- H0 in H.
  pose proof diamondp_negp_elim_infer1 B C.
  rewrite <- H1 in H.
  pose proof andp_assoc P0 B C.
  rewrite <- H2 in H.
  apply H. Qed.

Lemma boxp_one_unknown2: forall (B C: expr), |-- (diamondp (B && C) && diamondp (B && ~~C) && diamondp (~~B && C) && diamondp (~~B && ~~C)) --> P0 --> (~~boxp (~~(P0&&B&&C))).
Proof.
  intros.
  pose proof basic_situation2 P0 (B&&C).
  pose proof P_impp_boxp1.
  rewrite <- H0 in H.
  pose proof diamondp_negp_elim_infer1 B C.
  rewrite <- H1 in H.
  pose proof andp_assoc P0 B C.
  rewrite <- H2 in H.
  apply H. Qed.

Lemma boxp_from_unknown1: forall (B C: expr), |-- (~~ boxp (P0&&B&&C) && ~~ boxp (~~(P0&&B&&C))) --> P0.
Proof.
  intros.
  pose proof andp_intros_infer1 P0 B C.
  pose proof N_RULE _ H.
  pose proof K_AXIOM (~~ P0) (~~ (P0 && B && C)).
  pose proof modus_ponens _ _ H1 H0.
  pose proof P_impp_boxp2.
  rewrite <- H3 in H2.
  pose proof contrapositiveNP (boxp (~~ (P0 && B && C))) P0.
  pose proof modus_ponens _ _ H4 H2.
  pose proof aux_minimun_rule00 _ (~~ boxp (P0 && B && C)) H5.
  pose proof impp_curry (~~ boxp (P0 && B && C)) (~~ boxp (~~(P0 && B && C))) P0.
  pose proof modus_ponens _ _ H7 H6.
  apply H8. Qed.

Lemma boxp_from_unknown2: forall (A C: expr), |-- (~~ boxp (A&&P0&&C) && ~~ boxp (~~(A&&P0&&C))) --> P0.
Proof.
  intros.
  pose proof boxp_from_unknown1 A C.
  pose proof andp_comm A P0.
  rewrite H0.
  apply H. Qed.

Lemma boxp_two_unknown1: forall (A C: expr), |-- (diamondp (A && C) && diamondp (A && ~~C) && diamondp (~~A && C) && diamondp (~~A && ~~C)) --> boxp A --> P0 --> (~~boxp (A&&P0&&C)).
Proof.
  intros.
  pose proof basic_situation1 (A&&P0) C.
  pose proof boxp_andp_intros A P0.
  pose proof P_impp_boxp1.
  rewrite <- H1 in H0.
  rewrite <- H0 in H.
  pose proof diamondp_andp_minus A C.
  pose proof impp_curry (diamondp (A && C) && diamondp (A && ~~ C) && diamondp (~~ A && C) && diamondp (~~ A && ~~ C)) (boxp A) (diamondp C && diamondp (~~ C)).
  rewrite -> H3 in H2.
  rewrite <- H2 in H.
  pose proof andp_assoc_infer1 _ _ _ _ H.
  apply H4. Qed.

Lemma boxp_two_unknown2: forall (A C: expr), |-- (diamondp (A && C) && diamondp (A && ~~C) && diamondp (~~A && C) && diamondp (~~A && ~~C)) --> boxp A --> P0 --> (~~boxp (~~(A&&P0&&C))).
Proof.
  intros.
  pose proof basic_situation2 (A&&P0) C.
  pose proof boxp_andp_intros A P0.
  pose proof P_impp_boxp1.
  rewrite <- H1 in H0.
  rewrite <- H0 in H.
  pose proof diamondp_andp_minus A C.
  pose proof impp_curry (diamondp (A && C) && diamondp (A && ~~ C) && diamondp (~~ A && C) && diamondp (~~ A && ~~ C)) (boxp A) (diamondp C && diamondp (~~ C)).
  rewrite -> H3 in H2.
  rewrite <- H2 in H.
  pose proof andp_assoc_infer1 _ _ _ _ H.
  apply H4. Qed.

Lemma boxp_from_hear: forall (p q: expr), |-- boxp p --> boxp (p --> q) --> boxp q.
Proof.
  intros.
  pose proof aux_minimun_theorem02 p q.
  pose proof RK _ _ H.
  pose proof K_AXIOM (p --> q) q.
  rewrite -> H1 in H0.
  apply H0. Qed.

Lemma boxp_three_know: forall (A B: expr), |-- boxp A --> boxp B --> P0 --> boxp (A&&B&&P0).
Proof.
  intros.
  pose proof andp_intros_infer2 A B P0.
  pose proof N_RULE _ H.
  pose proof K_AXIOM A (B --> P0 --> A && B && P0).
  rewrite H1 in H0.
  pose proof K_AXIOM B (P0 --> A && B && P0).
  rewrite H2 in H0.
  pose proof K_AXIOM P0 (A && B && P0).
  rewrite H3 in H0.
  pose proof P_impp_boxp1.
  rewrite <- H4 in H0.
  apply H0. Qed.

End LemmaFromPubBaseAxiomatization.

Instance MLPubpbL_a: PubBaseLanguage MLPubL := {|
  boxp := ModalLogic_Pub.boxa;
  P0 := ModalLogic_Pub.A0
|}.

Instance MLPubpbAX_a: @PubBaseAxiomatization MLPubL _ _ MLPubpbL_a MLPubGamma _ _ _.
Proof.
  constructor.
  + apply ModalLogic_Pub.K_AXIOM_A.
  + apply ModalLogic_Pub.T_AXIOM_A.
  + apply ModalLogic_Pub.N_RULE_A.
  + apply ModalLogic_Pub.PUB_ASSERT_A.
Qed.

Instance boxa_proper_impp : Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) boxa.
Proof.
  pose proof boxp_proper_impp.
  apply H.
Qed.

Instance boxa_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) boxa.
Proof.
  pose proof boxp_proper_iffp.
  apply H.
Qed.

Instance MLPubpbL_b: PubBaseLanguage MLPubL := {|
  boxp := ModalLogic_Pub.boxb;
  P0 := ModalLogic_Pub.B0
|}.

Instance MLPubpbAX_b: @PubBaseAxiomatization MLPubL _ _ MLPubpbL_b MLPubGamma _ _ _.
Proof.
  constructor.
  + apply ModalLogic_Pub.K_AXIOM_B.
  + apply ModalLogic_Pub.T_AXIOM_B.
  + apply ModalLogic_Pub.N_RULE_B.
  + apply ModalLogic_Pub.PUB_ASSERT_B.
Qed.

Instance boxb_proper_impp : Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) boxb.
Proof.
  pose proof boxp_proper_impp.
  apply H.
Qed.

Instance boxb_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) boxb.
Proof.
  pose proof boxp_proper_iffp.
  apply H.
Qed.

Instance MLPubpbL_c: PubBaseLanguage MLPubL := {|
  boxp := ModalLogic_Pub.boxc;
  P0 := ModalLogic_Pub.C0
|}.

Instance MLPubpbAX_c: @PubBaseAxiomatization MLPubL _ _ MLPubpbL_c MLPubGamma _ _ _.
Proof.
  constructor.
  + apply ModalLogic_Pub.K_AXIOM_C.
  + apply ModalLogic_Pub.T_AXIOM_C.
  + apply ModalLogic_Pub.N_RULE_C.
  + apply ModalLogic_Pub.PUB_ASSERT_C.
Qed.

Instance boxc_proper_impp : Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) boxc.
Proof.
  pose proof boxp_proper_impp.
  apply H.
Qed.

Instance boxc_proper_iffp : Proper ((fun x y => |-- x <--> y) ==> (fun x y => |-- x <--> y)) boxc.
Proof.
  pose proof boxp_proper_iffp.
  apply H.
Qed.

Lemma boxa_one_unknown1: |--(diamonda (B0 && C0) && diamonda (B0 && ~~C0) && diamonda (~~B0 && C0) && diamonda (~~B0 && ~~C0)) --> A0 --> (~~boxa (A0&&B0&&C0)).
Proof.
  pose proof @boxp_one_unknown1 MLPubL _ _ MLPubpbL_a MLPubGamma _ _ _ _ _ B0 C0.
  apply H.
Qed.

Lemma boxa_one_unknown2: |-- (diamonda (B0 && C0) && diamonda (B0 && ~~C0) && diamonda (~~B0 && C0) && diamonda (~~B0 && ~~C0)) --> A0 --> (~~boxa (~~(A0&&B0&&C0))).
Proof.
  pose proof @boxp_one_unknown2 MLPubL _ _ MLPubpbL_a MLPubGamma _ _ _ _ _ B0 C0.
  apply H.
Qed.

Lemma boxa_from_unknown: |-- (~~ boxa (A0&&B0&&C0) && ~~ boxa (~~(A0&&B0&&C0))) --> A0.
Proof.
  pose proof @boxp_from_unknown1 MLPubL _ _ MLPubpbL_a MLPubGamma _ _ _ _ B0 C0.
  apply H.
Qed.

Lemma boxb_two_unknown1: |-- (diamondb (A0 && C0) && diamondb (A0 && ~~C0) && diamondb (~~A0 && C0) && diamondb (~~A0 && ~~C0)) --> boxb A0 --> B0 --> (~~boxb (A0&&B0&&C0)).
Proof.
  pose proof @boxp_two_unknown1 MLPubL _ _ MLPubpbL_b MLPubGamma _ _ _ _ _ A0 C0.
  apply H.
Qed.

Lemma boxb_two_unknown2: |-- (diamondb (A0 && C0) && diamondb (A0 && ~~C0) && diamondb (~~A0 && C0) && diamondb (~~A0 && ~~C0)) --> boxb A0 --> B0 --> (~~boxb (~~(A0&&B0&&C0))).
Proof.
  pose proof @boxp_two_unknown2 MLPubL _ _ MLPubpbL_b MLPubGamma _ _ _ _ _ A0 C0.
  apply H.
Qed.

Lemma boxb_from_unknown: |-- (~~ boxb (A0&&B0&&C0) && ~~ boxb (~~(A0&&B0&&C0))) --> B0.
Proof.
  pose proof @boxp_from_unknown2 MLPubL _ _ MLPubpbL_b MLPubGamma _ _ _ _ A0 C0.
  apply H.
Qed.

Lemma boxc_from_hear: forall (p q: L_Pub), |-- boxc p --> boxc (p --> q) --> boxc q.
Proof.
  intros.
  pose proof @boxp_from_hear MLPubL _ _ MLPubpbL_c MLPubGamma _ _ _ _ p q.
  apply H.
Qed.

Lemma boxc_three_know: |-- boxc A0 --> boxc B0 --> C0 --> boxc (A0&&B0&&C0).
Proof.
  pose proof boxp_three_know A0 B0.
  apply H.
Qed.

Lemma impp_curry_uncurry: forall p q r, |-- (p --> q --> r) <--> (p && q --> r).
Proof.
  intros.
  pose proof Intuitionistic.impp_curry_uncurry p q r.
  apply H.
Qed.

Lemma solve_impp_andp_infer1: forall p q r s, |-- p --> q --> r -> |-- p --> q --> s -> |-- p --> q --> r&&s.
Proof.
  intros.
  pose proof impp_curry_uncurry p q r.
  rewrite H1 in H.
  pose proof impp_curry_uncurry p q s.
  rewrite H2 in H0.
  pose proof solve_impp_andp (p && q) r s H H0.
  pose proof impp_curry_uncurry p q (r && s).
  rewrite <- H4 in H3.
  apply H3.
Qed.

Lemma solve_impp_andp_infer2: forall p q r s t, |-- p --> q --> r --> s -> |-- p --> q --> r --> t -> |-- p --> q --> r --> s&&t.
Proof.
  intros.
  pose proof impp_curry_uncurry p q (r --> s).
  pose proof impp_curry_uncurry (p && q) r s.
  rewrite H2 in H1.
  rewrite H1 in H.
  pose proof impp_curry_uncurry p q (r --> t).
  pose proof impp_curry_uncurry (p && q) r t.
  rewrite H4 in H3.
  rewrite H3 in H0.
  pose proof solve_impp_andp (p && q && r) s t H H0.
  pose proof impp_curry_uncurry p q (r --> s && t).
  pose proof impp_curry_uncurry (p && q) r (s && t).
  rewrite H7 in H6.
  rewrite <- H6 in H5.
  apply H5.
Qed.

Lemma impp_curry_uncurry_infer1: forall a b c p q, |-- (a --> p && q --> b --> c) -> |-- (a --> p --> q --> b --> c).
Proof.
  intros.
  pose proof impp_curry_uncurry p q (b --> c).
  rewrite <- H0 in H.
  apply H.
Qed.

Lemma A_DONT_KNOW: |-- boxa ((diamonda (B0 && C0) && diamonda (B0 && ~~C0) && diamonda (~~B0 && C0) && diamonda (~~B0 && ~~C0)) --> A0 --> (~~boxa (A0&&B0&&C0)) && (~~boxa (~~(A0&&B0&&C0)))).
Proof.
  pose proof boxa_one_unknown1.
  pose proof boxa_one_unknown2.
  pose proof solve_impp_andp_infer1 _ _ _ _ H H0.
  pose proof N_RULE_A _ H1.
  apply H2. Qed.

Lemma B_DONT_KNOW: |-- boxb ((diamondb (A0 && C0) && diamondb (A0 && ~~C0) && diamondb (~~A0 && C0) && diamondb (~~A0 && ~~C0)) --> boxb (~~boxa (A0&&B0&&C0) && ~~boxa (~~(A0&&B0&&C0))) --> B0 --> (~~boxb (A0&&B0&&C0)) && (~~boxb (~~(A0&&B0&&C0)))).
Proof.
  pose proof boxa_from_unknown.
  rewrite -> H.
  pose proof boxb_two_unknown1.
  pose proof boxb_two_unknown2.
  pose proof solve_impp_andp_infer2 _ _ _ _ _ H0 H1.
  pose proof N_RULE_B _ H2.
  apply H3. Qed.

Lemma C_KNOW: |-- boxc (boxc (~~boxa (A0&&B0&&C0) && ~~boxa (~~(A0&&B0&&C0))) --> boxc (boxb (~~boxa (A0&&B0&&C0) && ~~boxa (~~(A0&&B0&&C0)))) --> boxc (boxb (~~boxa (A0&&B0&&C0) && ~~boxa (~~(A0&&B0&&C0))) --> ~~boxb (A0&&B0&&C0) && ~~boxb (~~(A0&&B0&&C0))) --> C0 --> boxc (A0&&B0&&C0)).
Proof.
  pose proof boxc_from_hear (boxb (~~ boxa (A0 && B0 && C0) && ~~ boxa (~~ (A0 && B0 && C0)))) (~~ boxb (A0 && B0 && C0) && ~~ boxb (~~ (A0 && B0 && C0))).
  pose proof impp_curry_uncurry (boxc (boxb (~~ boxa (A0 && B0 && C0) && ~~ boxa (~~ (A0 && B0 && C0))))) (boxc (boxb (~~ boxa (A0 && B0 && C0) && ~~ boxa (~~ (A0 && B0 && C0))) --> ~~ boxb (A0 && B0 && C0) && ~~ boxb (~~ (A0 && B0 && C0)))) (boxc (~~ boxb (A0 && B0 && C0) && ~~ boxb (~~ (A0 && B0 && C0)))).
  rewrite -> H0 in H.
  pose proof boxa_from_unknown.
  pose proof boxb_from_unknown.
  pose proof boxc_three_know.
  rewrite <- H2 in H3 at 1.
  rewrite <- H1 in H3 at 1.
  rewrite <- H in H3.
  pose proof impp_curry_uncurry_infer1 _ _ _ _ _ H3.
  pose proof N_RULE_C _ H4.
  apply H5. Qed.

End ModalLogic_Pub.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require real.Real.
Require real.RealInfix.

Parameter pow2: Z -> R.

Axiom Power_0 : ((pow2 0%Z) = 1%R).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_s_all : forall (n:Z), ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (Rdiv 1%R 2%R)%R).

Axiom Power_1 : ((pow2 1%Z) = 2%R).

Axiom Power_neg1 : ((pow2 (-1%Z)%Z) = (05 / 10)%R).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 2.

(* Why3 goal *)
Theorem Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z ->
  ~ ((pow2 n) = 0%R).
intros n Hn.
generalize Hn.
pattern n; apply Z_lt_induction; auto.
ae.
Qed.


Load ch2_ref.

(* Chapter 2 Exercises *)
Section Chapter_2_Exercises.

  (* Exercise 2.1 *)
  (* let's redefine path composition 3 ways for the exercise *)
  Lemma pc1 {A : UU} {x y z : A} (p : x=y) (q : y=z) : x=z.
  Proof. induction p; induction q; reflexivity. Defined.
  Lemma pc2 {A : UU} {x y z : A} (p : x=y) (q : y=z) : x=z.
  Proof. induction p; apply q. Defined.
  Lemma pc3 {A : UU} {x y z : A} (p : x=y) (q : y=z) : x=z.
  Proof. induction q; apply p. Defined.

  Lemma pc1_is_2 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc1 p q = pc2 p q.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc2_is_3 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc2 p q = pc3 p q.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc1_is_3 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc1 p q = pc3 p q.
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.2 *)
  Lemma pc_proof_triangle {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc1 (pc1_is_2 p q) (pc2_is_3 p q) = pc1_is_3 p q.
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.3 *)
  Lemma pc4 {A : UU} {x y z : A} (p : x=y) (q : y=z) : x=z.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc4_is_1 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc4 p q = pc1 p q.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc4_is_2 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc4 p q = pc2 p q.
  Proof. (* fill in here... *)
  Defined.
  Lemma pc4_is_3 {A : UU} {x y z : A} (p : x=y) (q : y=z)
    : pc4 p q = pc3 p q.
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.4 *)
  (* from the book:
       Define, by induction on n, a general notion of
       'n-dimensional path' in a type A, simultaneously with
       the type of boundaries for such paths.

     fill in here... *)

  (* Exercise 2.5 *)
  (* function 2.3.6 *)
  Definition ap_to_apd {A B : UU} {x y : A} (f : A -> B) (p : x=y)
        (apf : f x = f y)
    : p # (f x) = f y
    := transport_const B p (f x) ∙ apf.
  (* function 2.3.7 *)
  Definition apd_to_ap {A B : UU} {x y : A} (f : A -> B) (p : x=y)
             (apdf : p # (f x) = f y)
    : f x = f y
    := inv (transport_const B p (f x)) ∙ apdf.
  (* state and prove that these are inverse equivalences *)
  (* fill in here... *)

  (* Exercise 2.6 *)
  (* note that this was left as an example in the chapter... *)
  Example example_2_4_8 {A : UU} {x y z : A} (p : x=y)
    : isequiv (λ q:y=z, p ∙ q).
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.7 *)
  Print ap_paireq.
  (* generalize the theorem just printed to Σ-types *)
  (* hint: try drawing topological pictures to get an intuition
           for why and where to use transports etc. *)
  (* fill in here *)

  (* Exercise 2.8 *)
  (* generalize the theorem from the last exercise to coproduct types
     instead of Σ-types now *)
  (* fill in here... *)
  (* not sure what this should be *)

  (* Exercise 2.9 *)
  Theorem univf_coprod {A B : UU} {X : UU}
    : (A + B -> X) ≃ (A -> X) × (B -> X).
  Proof. (* fill in here... *)
  Defined.
  (* state and prove a theorem 'univ_coprod', a dependent version *)
  (* note: can you basically copy and paste the proof from above?
           what does it mean to have a more general proposition
           proved by the same proof in light of Curry-Howard? *)
  (* fill in here... *)

  (* Exercise 2.10 *)
  Lemma sig_assoc {A : UU} {B : A -> UU} {C : total B -> UU}
    : (Σ (x:A) (y:B x), C{x;y}) ≃ (Σ (p:total B), C p).
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.11 *)
  (* how this all gets formalized might be tricky or up for debate. *)
  (* fill in here... *)

  (* Exercise 2.12 *)
  (* TODO... *)

  (* Exercise 2.13 *)
  Theorem two_is_two_is_two : (𝟚 ≃ 𝟚) ≃ 𝟚.
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.14 *)
  (* left for paper work... *)

  (* Exercise 2.15 *)
  Lemma stronger_2_10_5 {A : UU} {B : A->UU} {x y : A} {p : x=y}
    : transport B p = (idtoeqv (ap B p)).1 .
  Proof. (* fill in here... *)
  Defined.

  (* Exercise 2.16 *)
  (* skipping, due to comments on difficulty/reliance on
     un-covered material *)

  (* Exercise 2.17 *)
  Theorem prodeqv1 {A A' B B' : UU}
    : (A ≃ A')×(B ≃ B') -> (A×B) ≃ (A'×B').
  Proof. (* fill in here... *)
  Defined.

  Theorem prodeqv2 {A A' B B' : UU}
    : (A ≃ A')×(B ≃ B') -> (A×B) ≃ (A'×B').
  Proof. (* fill in here... *)
  Defined.

End Chapter_2_Exercises.


Theorem my_first_proof : (forall A : Prop, A -> A).
Proof.
  intros A.
  intros proof_of_A.
  exact proof_of_A.
Qed.


C02W82DBHV2R:~ i847419$ coqtop
Welcome to Coq 8.8.0 (April 2018)

Coq < Require Import Classical.

Coq < Theorem exp003: (forall M V : Prop, ((M /\ ~V) /\ ~M) -> V).
1 subgoal

  ============================
  forall M V : Prop, (M /\ ~ V) /\ ~ M -> V

exp003 < intros.
1 subgoal

  M, V : Prop
  H : (M /\ ~ V) /\ ~ M
  ============================
  V

exp003 < destruct H.
1 subgoal

  M, V : Prop
  H : M /\ ~ V
  H0 : ~ M
  ============================
  V

exp003 < destruct H.
1 subgoal

  M, V : Prop
  H : M
  H1 : ~ V
  H0 : ~ M
  ============================
  V

exp003 < tauto.
No more subgoals.

exp003 < Qed.
exp003 is defined


From discprob.basic Require Import base order nify exp_ext.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp quickselect_rec.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coquelicot Require Import Derive.
From Coquelicot Require AutoDerive.
Require Import Reals Fourier FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.

Module Type rec_factor.
  Parameter alpha : R.
  Parameter alpha_range: 1/2 < alpha < 1.
  Parameter ln_alpha: -/ln alpha > 1/alpha.
End rec_factor.

Module recurrence_log (ALPHA: rec_factor).
  Import ALPHA.
  Definition d := 1.
  Definition umin := 1.

  Definition a x :=
    match Rle_dec x 1 with
      | left _ => 0
      | _ =>
        match Rlt_dec x 2 with
        | left _ => (x - 1)
        | _ => 1
        end
    end.

  Definition m x :=
    match Rlt_dec x (1/alpha) with
      | left _ => 0
      | _ => x * alpha
    end.

  Definition k := -/ ln(alpha).

  Definition u x :=
    match Rle_dec x 1 with
      | left _ => 1
      | _ => ((k * ln x + 1))
    end.

  Definition u' x :=
    match Rle_dec x 1 with
      | left _ => 1
      | _ => exp ((x - 1) / k)
    end.

  Lemma umin_non_neg: 0 ≤ umin.
  Proof. rewrite /umin; fourier. Qed.

  Lemma Rlt_0_ln x: 1 < x → 0 < ln x.
  Proof.
    intros Hlt; rewrite -ln_1; apply ln_increasing; fourier.
  Qed.

  Lemma one_lt_inv_alpha:
    1 < / alpha.
  Proof.
    generalize (alpha_range), ln_alpha; intros.
    apply (Rmult_lt_reg_l alpha); first nra. field_simplify; nra.
  Qed.

  Lemma kgt1: 1 < k.
  Proof.
    generalize (alpha_range), ln_alpha; intros.
    rewrite /k.
    transitivity (/ alpha); last auto; try nra.
    apply one_lt_inv_alpha.
  Qed.

  Lemma kgt0: 0 < k.
  Proof.
    etransitivity; last apply kgt1. fourier.
  Qed.

  Lemma u_mono x y: x ≤ y → u x ≤ u y.
  Proof.
    rewrite /u/a/m/d => Hle.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    -
      cut (0 ≤ ln y).
      {
        intros. generalize kgt1 => ?.
        assert (k * ln y ≥ 0).
        { transitivity (1 * ln y); last fourier.
          apply Rle_ge, Rmult_le_compat; try fourier.
        }
        fourier.
      }
      left. apply Rlt_0_ln; nra.
    - specialize (kgt0) => Hk.
      apply Rplus_le_compat; last nra.
      cut (ln x ≤ ln y).
      {
        specialize (kgt0); cut (0 ≤ ln x); intros; first apply Rmult_le_compat; auto; try fourier.
        rewrite -(ln_1). left; apply ln_increasing; nra.
      }
      * inversion Hle; auto; subst; last by nra. left. apply ln_increasing; intros; nra.
  Qed.

  (* This basically covers half the case for the above, so could remove some redundancy *)
  Lemma u_strict_inc x y: x ≥ d → x < y → u x < u y.
  Proof.
    rewrite /u/a/m/d => Hle Hlt.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    - specialize (kgt0) => Hk.
      assert (0 < k * ln y).
      {
        apply Rmult_lt_0_compat; first nra.
        apply Rlt_0_ln; fourier.
      }
      rewrite ?Rmult_1_r //=; nra.
    - specialize (kgt0) => Hk.
      apply Rplus_lt_compat_r.
      cut (ln x < ln y).
      {
        specialize (kgt0); cut (0 < ln x); intros; first apply Rmult_lt_compat_l; auto; try fourier.
        rewrite -(ln_1). apply ln_increasing; nra.
      }
      apply ln_increasing; nra.
  Qed.

  Lemma u'_mono x y: x ≤ y → u' x ≤ u' y.
  Proof.
    rewrite /u'/a/m/d => Hle.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    - rewrite -{1}exp_0.
      left; apply exp_increasing.
      rewrite /Rdiv. apply Rlt_mult_inv_pos; last apply kgt0. nra.
    - apply exp_increasing_le.
      generalize (kgt0) => Hk.
      apply Rdiv_le_compat_contra; nra.
  Qed.

  Lemma u'_pos x: u' x > 0.
  Proof.
    rewrite /u'/a/m/d.
    destruct (Rle_dec _); try nra.
    apply exp_pos.
  Qed.

  Lemma u'_inv_above x: d < x → u' (u x) = x.
  Proof.
    rewrite /u/u'/d.
    destruct (Rle_dec) as [Hc1|Hc1] => //=; try nra;
    destruct (Rle_dec) as [Hc2|Hc2] => //=; try nra.
    - intros. exfalso.
      assert (0 < ln x) by (apply Rlt_0_ln; auto).
      assert (0 < k * ln x) by (apply Rmult_lt_0_compat; auto using kgt0).
      assert (0 < (k * ln x) * (k * ln x)) by (repeat apply Rmult_lt_0_compat; auto using kgt0).
      nra.
    - rewrite -[a in _ = a]exp_ln; last nra.
      intros; do 1 f_equal.
      assert (0 < ln x) by (apply Rlt_0_ln; auto).
      assert (0 < k * ln x) by (apply Rmult_lt_0_compat; auto using kgt0).
      field. apply Rgt_not_eq, kgt0.
  Qed.

  Lemma u'u x: x ≤ u' (u x).
  Proof.
    destruct (Rlt_dec 1 x) as [Hlt|Hnlt].
    - rewrite u'_inv_above //. reflexivity.
    - rewrite /u/u'.
      apply Rnot_lt_le in Hnlt.
      destruct (Rle_dec) => //=; try nra.
      destruct (Rle_dec) => //=; try nra.
  Qed.

  Lemma u_inv_above x: umin < x → u (u' x) = x.
  Proof.
    rewrite /u/u'/umin.
    destruct (Rle_dec) as [Hc1|?] => //=; try nra;
    destruct (Rle_dec) as [?|?] => //=; try nra.
    - exfalso. rewrite -{2}exp_0 in Hc1.
      apply exp_le_embedding in Hc1.
      specialize (kgt1) => Hk.
      cut (0 < (x - 1) / k).
      { by intros ?%Rlt_not_le. }
      apply Rdiv_lt_0_compat; nra.
    - rewrite ln_exp. rewrite /Rdiv. intros.
      field. apply Rgt_not_eq, kgt0.
  Qed.

  Lemma ud_umin: u d = umin.
  Proof.
    rewrite /u/d/umin//=.
    destruct (Rle_dec); nra.
  Qed.

  Lemma u_cont: continuity u.
  Proof.
    apply piecewise_continuity' with (g := λ x, (k * ln x + 1))
                                      (f := λ x, 1) (z := 1).
    - intros; apply continuity_const => ? //.
    - intros. repeat apply continuity_pt_mult.
      * apply continuity_pt_plus.
        ** apply continuity_pt_mult.
           *** apply continuity_pt_const => ? //.
           *** apply ln_continuity_pt; fourier.
        ** apply continuity_pt_const => ? //.
    - rewrite /u => x. destruct (Rle_dec); nra.
    - rewrite /u => x.
      destruct (Rle_dec); intros.
      * assert (x = 1) as -> by (apply Rle_antisym; fourier).
        rewrite ln_1 Rmult_0_r Rplus_0_l. done.
      * done.
  Qed.

  Lemma a_cont_pt: ∀ x, d < x → continuity_pt a x.
  Proof.
    rewrite /d. intros.
    apply piecewise_continuity_pt with (P := λ x, d < x)
                                               (g := λ x,
                                                     match Rlt_dec x 2 with
                                                     | left _ => (x - 1)
                                                     | _ => 1
                                                     end)
                                               (f := λ x, 0) (z := 1).
    - intros. apply continuity_const => ??. done.
    - intros. apply piecewise_continuity_pt with (g := λ x, 1)
                                                 (f := λ x, (x - 1))
                                                 (z := 2)
                                                 (P := λ x, d < x);
                try (intros; destruct (Rlt_dec); nra); try nra.
      * rewrite /d. intros.
        ** apply continuity_minus.
           *** apply continuity_id => ??.
           *** apply continuity_const => ??. done.
      * intros. apply continuity_const => ?? //=.
    - intros x'. rewrite /a. destruct Rle_dec; try nra; destruct Rlt_dec; nra.
    - intros x'. rewrite /a. destruct Rle_dec; nra.
    - rewrite /d. intros. fourier.
    - rewrite /d. fourier.
  Qed.

  Lemma kinv: /k = ln (/alpha).
  Proof.
    rewrite /k.
    generalize (alpha_range), ln_alpha; intros.
    rewrite ln_Rinv; last by nra.
    assert (0 < ln (/alpha)).
    { rewrite -ln_1. apply ln_increasing; first nra. apply one_lt_inv_alpha. }
    rewrite Ropp_inv_permute.
    - rewrite Rinv_involutive //.
      cut (ln alpha ≠ 0); first by nra.
      apply Rlt_not_eq. rewrite -ln_1.
      apply ln_increasing; nra.
    - cut (ln alpha ≠ 0); first by nra.
      apply Rlt_not_eq. rewrite -ln_1.
      apply ln_increasing; nra.
  Qed.

  Lemma urec0 x: x > d → u x ≥ a x + u (m x).
  Proof.
    generalize (alpha_range), ln_alpha => ??.
    rewrite /u/a/m/d.
    destruct (Rle_dec) as [Hc1|Hc1] => //=; first nra.
    destruct (Rle_dec) as [Hc2|Hc2] => //=.
    - destruct (Rlt_dec) as [?|?].
      {
        destruct (Rlt_dec) as [?|?]; try nra; last first.
        { intros.
          assert (1 / alpha < 2).
          { destruct alpha_range as (Hlt&?).
            apply Rinv_lt_contravar in Hlt; last nra.
            nra.
          }
          nra.
        }
        intros.
        transitivity (x - 1 +  1); last first.
        { right. field. }
        cut (k * ln x > x - 1); first by (intros; fourier).
        cut (k * ln x - (x - 1) > 0); first by (intros; fourier).
        apply Rlt_gt.
        eapply (Rle_lt_trans _ (k * ln(1) - (1 - 1))).
        { right. rewrite ln_1 Rmult_0_r. field. }
        eapply incr_function_le with (f := λ x, k * ln x - (x - 1))
                                               (x := 1)
                                               (y := x)
                                               (a := 1)
                                               (b := /alpha)
                                               (df := λ x, k * 1/x - 1); try fourier; eauto.
        * rewrite //= => ???. AutoDerive.auto_derive; nra.
        * rewrite //=. intros x' ? ?.
          cut (k */ x' > 1).
          { intros. set (p := k */ x'). assert (p > 1) by (rewrite /p; auto).
            nra.
          }
          apply Rlt_gt, (Rmult_lt_reg_r x'); first fourier.
          rewrite Rmult_assoc Rinv_l; first (rewrite /k; nra).
          apply Rgt_not_eq; fourier.
        * rewrite //=. nra.
        * rewrite //=. nra.
      }
      assert (x = /alpha) as ->.
      {
        apply (Rmult_le_compat_r (/alpha)) in Hc2; last first.
        {
          left. transitivity 1; first nra. apply one_lt_inv_alpha.
        }
        rewrite Rmult_assoc Rinv_r in Hc2; last first.
        { apply Rgt_not_eq. nra. }
        rewrite Rmult_1_l Rmult_1_r in Hc2.
        apply Rle_antisym; nra.
      }
      destruct (Rlt_dec); last by nra.
      intros; rewrite -kinv Rinv_r; first nra.
      apply Rgt_not_eq, kgt0.
    - assert (0 < ln x) by (apply Rlt_0_ln; nra).
      destruct (Rlt_dec); first by nra; intros.
      intros; rewrite ln_mult; try nra.
      rewrite (Rmult_plus_distr_l k _).
      assert (k * ln (alpha) = -1) as ->.
      { rewrite /k. field. apply Rlt_not_eq.
        rewrite -(ln_1). apply ln_increasing; nra.
      }
      destruct Rlt_dec.
      * field_simplify; last nra.
      * rewrite /Rdiv; first fourier.
  Qed.

  Lemma alower: ∀ x, x ≤ d → a x = 0.
  Proof.
    rewrite /a => x; destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma a_nonneg: ∀ x, a x ≥ 0.
  Proof.
    intros. rewrite /a. destruct (Rlt_dec); destruct (Rle_dec); nra.
  Qed.

  Lemma a_pos: ∀ x, d < x → 0 < a x.
  Proof.
    rewrite /d/a => ??. destruct (Rlt_dec); destruct (Rle_dec); nra.
  Qed.

  Lemma a_mono: Rmono a.
  Proof.
    rewrite /Rmono. intros x x' Hle.
    inversion Hle; subst; try reflexivity.
    destruct (Rle_dec d x) as [?|?%Rnot_le_gt].
    * rewrite /a. do 2 (destruct (Rle_dec); try destruct (Rlt_dec)); nra.
    * rewrite alower; auto; try fourier. apply Rge_le, a_nonneg.
  Qed.

  Lemma mnondec: ∀ y y', 0 < y → y ≤ y' → (m y / y) ≤ (m y' / y').
  Proof.
    generalize (alpha_range), ln_alpha => ??.
    intros y y' Hlt Hle.
    rewrite /m.
    destruct (Rlt_dec).
    {  destruct (Rlt_dec).
       - intros. rewrite /Rdiv ?Rmult_0_l. fourier.
       - intros. rewrite /Rdiv ?Rmult_0_l.
         rewrite Rmult_comm -Rmult_assoc Rinv_l; nra.
    }
    destruct (Rlt_dec); first by nra.
    intros. right. field. split; apply Rgt_not_eq; fourier.
  Qed.

  Lemma d_non_neg: 0 ≤ d.
  Proof.
    rewrite /d. fourier.
  Qed.

End recurrence_log.


Require Import Arith.
Require Import Coq.Logic.JMeq.
Inductive fin:nat->Type:=
|car:forall m,fin m
|cdr:forall m:nat,fin m->fin(S m).
Program Fixpoint getfin(i n:nat):fin n:=
match n as x with
|0=>car n
|S n'=>match i with
|0=>car n
|S i'=>cdr _ (getfin i' n')
end end.

Definition cons n(i0:nat)(rest:fin n->nat):fin (S n)->nat.
intro.
generalize (refl_equal (S n)).
pattern n at 2.
refine match H in (fin k)
return (S n=k->nat)
with
|car Sn=>(fun _ _=>i0) Sn
|cdr n0 rest'=> _ n0
end.
intros.
SearchPattern (S _=S _->_=_).
apply eq_add_S in H0.
rewrite <-H0 in rest'.
exact (rest rest').
Defined.

Definition nil(_:fin 0):nat:=0.

Notation "[ a , b ]" := (cons _ a b).

Eval compute in getfin 3 4.
Inductive Recu:nat->Type:=
|add:Recu 2
|mul:Recu 2
|proj:forall k,fin k->Recu k
|equal:Recu 2
|synth:forall n:nat,forall m:nat,(fin n->Recu m)->Recu n->Recu m
|mu:forall n:nat,forall con:nat->fin n->Prop,forall argv:fin n,(exists b:nat,con b argv)->Recu n.
Definition nth n(argv:fin n->nat)(i:nat):nat
:=
if negb(leb i n) then argv (getfin i n) else 0.

Notation "a [ b ]":=(nth _ a b) (at level 200).

Definition eqtest m n(H:m=n)(i:fin m->nat):fin n->nat.
rewrite <-H.
exact i.
Defined.
Print eqtest.
Print eq_rec.

Program Fixpoint eval n (f:Recu n)(a:fin n->nat):nat:=
match f with
|add=>((nth _ a 0) + (nth _ a 1))
|mul=>((nth _ a 0) * (nth _ a 1))
|proj k ind=>a _
|equal=> if(beq_nat (nth _ a 0)(nth _ a 1)) then 1 else 0
|synth k n funcs g=> eval k g (fun i:fin k=>eval n ( funcs i) (eqtest _ _ _ a))
|mu n con argv proof=> match proof  as H with
|ex_intro x H00=>
((fix tmp0(y:nat):nat:=
match y with
|0=>x
|S y'=>if (negb (leb x (x-y)))
then x-y else tmp0 y' end)x)
end
end.
Obligation 1.
apply ind.
Defined.


(**
Here we define the signature for the integers modulo 2.

These are defined as the following HIT:
HIT mod2 :=
| 0 : mod2
| S : mod2 → mod2
| mod : ∏ (n : mod2), S(S n) = n
| ap_mod : ∏ (n : mod2), ap S (mod n) = mod (S n)
We study the 1-truncation.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import displayed_algebras.displayed_algebra.
Require Import displayed_algebras.globe_over_lem.

Local Open Scope cat.

Definition mod2_point_constr
  : poly_code
  := C unit_one_type + I.

Definition mod2_paths : UU := unit.

Definition mod2_paths_args (j : mod2_paths) : poly_code := I.

Definition zero_e
           (P : poly_code)
  : endpoint mod2_point_constr P I
  := comp
       (comp
          (c P (tt : unit_one_type))
          (ι₁ _ _))
       constr.

Definition suc_e
           {P : poly_code}
           (e : endpoint mod2_point_constr P I)
  : endpoint mod2_point_constr P I
  := comp e (comp (ι₂ _ _) constr).

Definition mod2_paths_lhs
           (i : mod2_paths)
  : endpoint mod2_point_constr (mod2_paths_args i) I
  := suc_e (suc_e (id_e _ _)).

Definition mod2_paths_rhs
           (i : mod2_paths)
  : endpoint mod2_point_constr (mod2_paths_args i) I
  := id_e _ _.

Definition mod2_homots : UU := unit.

Definition mod2_homots_point_arg
           (i : mod2_homots)
  : poly_code
  := I.

Definition mod2_homots_point_left_endpoint
           (i : mod2_homots)
  : endpoint mod2_point_constr (mod2_homots_point_arg i) I
  := suc_e (suc_e (suc_e (id_e _ _))).

Definition mod2_homots_point_right_endpoint
           (i : mod2_homots)
  : endpoint mod2_point_constr (mod2_homots_point_arg i) I
  := suc_e (id_e _ _).

Definition mod2_e
           {i : mod2_homots}
           (e : endpoint mod2_point_constr (mod2_homots_point_arg i) I)
  : homot_endpoint
      mod2_paths_lhs
      mod2_paths_rhs
      (c (mod2_homots_point_arg i) (tt : unit_one_type))
      (c (mod2_homots_point_arg i) (tt : unit_one_type))
      (suc_e (suc_e e))
      e
  := trans_e
       (ap_e
          _
          (trans_e
             (ap_e
                _
                (inv_e (comp_id_r _)))
             (inv_e (comp_assoc _ _ _))))
       (trans_e
          (inv_e (comp_assoc _ _ _))
          (trans_e
             (path_constr tt _)
             (comp_id_r _))).

Definition ap_suc_e
           {i : mod2_homots}
           {e₁ e₂ : endpoint mod2_point_constr (mod2_homots_point_arg i) I}
           (h : homot_endpoint
                  mod2_paths_lhs
                  mod2_paths_rhs
                  (c (mod2_homots_point_arg i) (tt : unit_one_type))
                  (c (mod2_homots_point_arg i) (tt : unit_one_type))
                  e₁
                  e₂)
  : homot_endpoint
      mod2_paths_lhs
      mod2_paths_rhs
      (c (mod2_homots_point_arg i) (tt : unit_one_type))
      (c (mod2_homots_point_arg i) (tt : unit_one_type))
      (suc_e e₁)
      (suc_e e₂)
  := trans_e
       (comp_assoc _ _ _)
       (trans_e
          (ap_e _ (ap_e _ h))
          (inv_e (comp_assoc _ _ _))).

Definition mod2_homots_point_rhs
           (i : mod2_homots)
  : homot_endpoint
      mod2_paths_lhs
      mod2_paths_rhs
      (c (mod2_homots_point_arg i) (tt : unit_one_type))
      (c (mod2_homots_point_arg i) (tt : unit_one_type))
      (mod2_homots_point_left_endpoint i)
      (mod2_homots_point_right_endpoint i)
  := ap_suc_e
       (trans_e
          (inv_e (comp_id_l _))
          (trans_e
             (path_constr tt _)
             (comp_id_l _))).

Definition mod2_homots_point_lhs
           (i : mod2_homots)
  : homot_endpoint
      mod2_paths_lhs
      mod2_paths_rhs
      (c (mod2_homots_point_arg i) (tt : unit_one_type))
      (c (mod2_homots_point_arg i) (tt : unit_one_type))
      (suc_e (suc_e (suc_e (id_e _ _))))
      (suc_e (id_e _ _))
  := mod2_e (suc_e (id_e _ _)).

Definition mod2_signature
  : hit_signature.
Proof.
  simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _ ,, _  ,, _ ,, _ ,, _ ,, _).
  - exact mod2_point_constr.
  - exact mod2_paths.
  - exact mod2_paths_args.
  - exact mod2_paths_lhs.
  - exact mod2_paths_rhs.
  - exact mod2_homots.
  - exact mod2_homots_point_arg.
  - exact (λ _, C unit_one_type).
  - exact (λ _, @c _ _ unit_one_type tt).
  - exact (λ _, @c _ _ unit_one_type tt).
  - exact mod2_homots_point_left_endpoint.
  - exact mod2_homots_point_right_endpoint.
  - exact mod2_homots_point_lhs.
  - exact mod2_homots_point_rhs.
Defined.

Section Mod2AlgebraProjections.
  Variable (X : hit_algebra_one_types mod2_signature).

  Definition mod2_carrier
    : one_type
    := pr111 X.

  Definition mod2_Z
    : mod2_carrier
    := pr211 X (inl tt).

  Definition mod2_S
    : mod2_carrier → mod2_carrier
    := λ x, pr211 X (inr x).

  Definition mod2_mod
    : ∏ (x : mod2_carrier), mod2_S (mod2_S x) = x
    := pr21 X tt.

  Definition mod2_ap_mod
    : ∏ (n : mod2_carrier),
      maponpaths mod2_S (mod2_mod n)
      =
      mod2_mod (mod2_S n).
  Proof.
    intro n.
    refine (!(maponpathscomp inr (pr211 X) (mod2_mod n)) @_).
    refine (_@ pathscomp0rid _).
    refine (_@ !(pr2 X tt n (idpath _))).
    refine (_@ !(pathscomp0rid _)).
    rewrite pathscomp0rid.
    apply idpath.
  Defined.
End Mod2AlgebraProjections.

Section Mod2Induction.
  Context {X : hit_algebra_one_types mod2_signature}
          (Y : alg_carrier X → one_type)
          (YZ : Y (mod2_Z X))
          (YS : ∏ (n : alg_carrier X), Y n → Y (mod2_S X n))
          (Ymod : ∏ (n : alg_carrier X) (y : Y n),
                  @PathOver _ _ _ (mod2_mod X n) Y (YS _ (YS n y)) y)
          (Yap_mod : ∏ (n : alg_carrier X)
                       (nn : Y n),
                     globe_over
                       Y
                       (mod2_ap_mod X n)
                       (@apd_2 _ _ _ Y (mod2_S X) YS _ _ (mod2_mod X n) _ _ (Ymod n nn))
                       (Ymod (mod2_S X n) (YS n nn))).

  Local Definition cY
    : ∏ (x : poly_act (point_constr mod2_signature) (alg_carrier X)),
      poly_dact (point_constr mod2_signature) Y x → Y (alg_constr X x).
  Proof.
    intros x xx.
    induction x as [ | x].
    - induction a.
      exact YZ.
    - exact (YS x xx).
  Defined.

  Definition make_mod2_disp_algebra
    : disp_algebra X.
  Proof.
    use make_disp_algebra.
    - exact Y.
    - exact cY.
    - intros j x y.
      induction j.
      exact (Ymod x y).
    - abstract
        (intros j n nn p pp ;
         induction j ;
         refine (globe_over_move_globe_one_type _ _) ;
         [ apply (pr111 X)
         | refine (concat_globe_over
                     (globe_over_compose_left'
                        _
                        (globe_over_id_left _))
                     _) ;
           refine (concat_globe_over
                     (globe_over_compose_left'
                        _
                        (globe_over_id_right _))
                     _) ;
           refine (inv_globe_over _) ;
           refine (concat_globe_over
                     (globe_over_id_left _)
                     _) ;
           refine (concat_globe_over
                     (globe_over_id_right _)
                     _) ;
           refine (concat_globe_over
                     (apd2_comp dep_inr_fun _ _)
                     _) ;
           refine (concat_globe_over
                     (@apd2_globe_over
                        _ _ Y Y
                        _ YS
                        _ _ _ _ _ _ _ _ _
                        (concat_globe_over
                           (globe_over_id_left _)
                           (globe_over_id_right _)))
                     _) ;
           refine (concat_globe_over
                     (Yap_mod n nn)
                     _) ;
           refine (inv_globe_over _) ;
           apply globe_over_id_left]).
  Defined.

  Variable (HX : is_HIT mod2_signature X).

  (** Induction principle *)
  Definition mod2_ind_disp_algebra_map
    : disp_algebra_map make_mod2_disp_algebra
    := HX make_mod2_disp_algebra.

  Definition mod2_ind
    : ∏ (x : alg_carrier X), Y x
    := pr1 mod2_ind_disp_algebra_map.

  Definition mod2_ind_Z
    : mod2_ind (mod2_Z X) = YZ
    := pr12 mod2_ind_disp_algebra_map (inl tt).

  Definition mod2_ind_S
             (n : alg_carrier X)
    : mod2_ind (mod2_S X n) = YS n (mod2_ind n)
    := pr12 mod2_ind_disp_algebra_map (inr n).

  Definition mod2_ind_mod
             (n : alg_carrier X)
    : PathOver_square
        _
        (idpath _)
        (apd (pr1 mod2_ind_disp_algebra_map) (alg_path X tt n))
        (Ymod n (pr1 mod2_ind_disp_algebra_map n))
        (pr12 mod2_ind_disp_algebra_map
              (inr ((pr211 X) (inr n)))
         @ maponpaths
             (λ x : Y ((pr211 X) (inr n)), YS ((pr211 X) (inr n)) x)
             ((pr12 mod2_ind_disp_algebra_map) (inr n)))
        (idpath (pr1 mod2_ind_disp_algebra_map n)).
  Proof.
    pose (pr22 mod2_ind_disp_algebra_map tt n) as p.
    simpl in p.
    cbn in p.
    rewrite !pathscomp0rid in p.
    exact p.
  Qed.
End Mod2Induction.


Require Export P02.

(** **** Problem #3 : 2 stars (mult_S_1) *)
Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
  intros n m.
  intros K.
  rewrite -> K.
  reflexivity.
Qed.

(*-- Check --*)

Check mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.


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

 Displayed monoidal categories

 In this file, we define the notion of a displayed monoidal category. The style of
 the definition is similar to the definition of a monoidal category.

Note: after refactoring on March 10, 2023, the prior Git history of this development is found via
git log -- UniMath/CategoryTheory/Monoidal/DisplayedMonoidalWhiskered.v

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Import MonoidalNotations.
Import DisplayedBifunctorNotations.

Section DisplayedMonoidalCategories.

  Definition disp_tensor
             {C : category}
             (D : disp_cat C)
             (M : monoidal C)
    : UU
    := disp_bifunctor M D D D.

  Identity Coercion disptensor_into_dispbifunctor : disp_tensor >-> disp_bifunctor.

  Definition disp_leftunitor_data
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DT : disp_tensor D M)
             (i : D I_{M})
    : UU
    := ∏ (x : C) (xx : D x), i ⊗⊗_{DT} xx -->[lu^{M}_{x}] xx.

  Definition disp_leftunitorinv_data
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DT : disp_tensor D M)
             (i : D I_{M})
    : UU
    := ∏ (x : C) (xx : D x), xx -->[luinv^{M}_{x}] i ⊗⊗_{DT} xx.

  Definition disp_rightunitor_data
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DT : disp_tensor D M)
             (i : D I_{M})
    : UU
    := ∏ (x : C) (xx : D x), xx ⊗⊗_{DT} i -->[ru^{M}_{x}] xx.

  Definition disp_rightunitorinv_data
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DT : disp_tensor D M)
             (i : D I_{M})
    : UU
    := ∏ (x : C) (xx : D x), xx -->[ruinv^{M}_{x}] xx ⊗⊗_{DT} i.

  Definition disp_associator_data
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DT : disp_tensor D M)
    : UU
    := ∏ (x y z : C) (xx : D x) (yy : D y) (zz : D z),
       (xx ⊗⊗_{DT} yy) ⊗⊗_{DT} zz
       -->[α^{M}_{x,y,z}]
       xx ⊗⊗_{DT} (yy ⊗⊗_{DT} zz).

  Definition disp_associatorinv_data
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DT : disp_tensor D M)
    : UU
    := ∏ (x y z : C) (xx : D x) (yy : D y) (zz : D z),
       xx ⊗⊗_{DT} (yy ⊗⊗_{DT} zz)
       -->[αinv_{M} x y z]
       (xx ⊗⊗_{DT} yy) ⊗⊗_{DT} zz.

  Definition disp_monoidal_data
             {C : category}
             (D : disp_cat C)
             (M : monoidal C)
    : UU
    := ∑ (DT : disp_tensor D M)
         (i : D I_{M}),
       (disp_leftunitor_data DT i)
       × (disp_leftunitorinv_data DT i)
       × (disp_rightunitor_data DT i)
       × (disp_rightunitorinv_data DT i)
       × (disp_associator_data DT)
       × (disp_associatorinv_data DT).

  Definition disp_monoidal_tensor
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DMD : disp_monoidal_data D M)
    : disp_tensor D M
    := pr1 DMD.

  Coercion disp_monoidal_tensor : disp_monoidal_data >-> disp_tensor.

  Definition disp_monoidal_unit
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DMD : disp_monoidal_data D M)
    : D I_{M}
    := pr12 DMD.

  Notation "dI_{ DMD }" := (disp_monoidal_unit DMD).

  Definition disp_monoidal_leftunitor
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DMD : disp_monoidal_data D M)
    : disp_leftunitor_data DMD dI_{DMD}
    := pr122 DMD.

  Notation "dlu_{ DMD }" := (disp_monoidal_leftunitor DMD).

  Definition disp_monoidal_leftunitorinv
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DMD : disp_monoidal_data D M)
    : disp_leftunitorinv_data DMD dI_{DMD}
    := pr1 (pr222 DMD).

  Notation "dluinv_{ DMD }" := (disp_monoidal_leftunitorinv DMD).

  Definition disp_monoidal_rightunitor
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DMD : disp_monoidal_data D M)
    : disp_rightunitor_data DMD dI_{DMD}
    := pr12 (pr222 DMD).

  Notation "dru_{ DMD }" := (disp_monoidal_rightunitor DMD).

  Definition disp_monoidal_rightunitorinv
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DMD : disp_monoidal_data D M)
    : disp_rightunitorinv_data DMD dI_{DMD}
    := pr122 (pr222 DMD).

  Notation "druinv_{ DMD }" := (disp_monoidal_rightunitorinv DMD).

  Definition disp_monoidal_associator
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DMD : disp_monoidal_data D M)
    : disp_associator_data DMD
    := pr1 (pr222 (pr222 DMD)).

  Notation "dα_{ DMD }" := (disp_monoidal_associator DMD).

  Definition disp_monoidal_associatorinv
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DMD : disp_monoidal_data D M)
    : disp_associatorinv_data DMD
    := pr2 (pr222 (pr222 DMD)).

  Notation "dαinv_{ DMD }" := (disp_monoidal_associatorinv DMD).

  (** PROPERTIES **)

  Definition disp_leftunitor_nat
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             (dlu : disp_leftunitor_data DT i)
    : UU
    := ∏ (x y : C)
         (f : C⟦x,y⟧)
         (xx : D x) (yy : D y)
         (ff : xx -->[f] yy),
       (i ⊗⊗^{DT}_{l} ff) ;; (dlu y yy)
       =
       transportb
         _
         (pr1 (monoidal_leftunitorlaw M) _ _ _)
         (dlu x xx ;; ff).

  Definition disp_leftunitor_iso
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             (dlu : disp_leftunitor_data DT i)
             (dluinv : disp_leftunitorinv_data DT i)
    : UU
    := ∏ (x : C) (xx : D x),
       is_disp_inverse
         (pr2 (monoidal_leftunitorlaw M) x)
         (dlu x xx)
         (dluinv x xx).

  Definition disp_leftunitor_law
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             (dlu : disp_leftunitor_data DT i)
             (dluinv : disp_leftunitorinv_data DT i)
    : UU
    := disp_leftunitor_nat dlu × disp_leftunitor_iso dlu dluinv.

  Definition disp_leftunitorlaw_nat
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             {dlu : disp_leftunitor_data DT i}
             {dluinv : disp_leftunitorinv_data DT i}
             (dlun : disp_leftunitor_law dlu dluinv)
    : disp_leftunitor_nat dlu
    := pr1 dlun.

  Definition disp_leftunitorlaw_iso
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             {dlu : disp_leftunitor_data DT i}
             {dluinv : disp_leftunitorinv_data DT i}
             (dlui : disp_leftunitor_law dlu dluinv)
    : disp_leftunitor_iso dlu dluinv
    := pr2 dlui.

  Definition disp_rightunitor_nat
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             (dru : disp_rightunitor_data DT i)
    : UU
    := ∏ (x y : C)
         (f : C⟦x,y⟧)
         (xx : D x) (yy : D y)
         (ff : xx -->[f] yy),
       (ff ⊗⊗^{DT}_{r} i) ;; (dru y yy)
       =
       transportb
         _
         (pr1 (monoidal_rightunitorlaw M) _ _ _)
         (dru x xx ;; ff).

  Definition disp_rightunitor_iso
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             (dru : disp_rightunitor_data DT i)
             (druinv : disp_rightunitorinv_data DT i)
    : UU
    := ∏ (x : C) (xx : D x),
       is_disp_inverse
         (pr2 (monoidal_rightunitorlaw M) x)
         (dru x xx)
         (druinv x xx).

  Definition disp_rightunitor_law
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             (dru : disp_rightunitor_data DT i)
             (druinv : disp_rightunitorinv_data DT i)
    : UU
    := disp_rightunitor_nat dru × disp_rightunitor_iso dru druinv.

  Definition disp_rightunitorlaw_nat
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             {dru : disp_rightunitor_data DT i}
             {druinv : disp_rightunitorinv_data DT i}
             (drun : disp_rightunitor_law dru druinv)
    : disp_rightunitor_nat dru
    := pr1 drun.

  Definition disp_rightunitorlaw_iso
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             {dru : disp_rightunitor_data DT i}
             {druinv : disp_rightunitorinv_data DT i}
             (drui : disp_rightunitor_law dru druinv)
    : disp_rightunitor_iso dru druinv
    := pr2 drui.

  Definition disp_associator_nat_leftwhisker
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             (dα : disp_associator_data DT)
    : UU
    := ∏ (x y z1 z2 : C)
         (h : C⟦z1,z2⟧)
         (xx : D x)
         (yy : D y)
         (zz1 : D z1)
         (zz2 : D z2)
         (hh : zz1-->[h] zz2),
       (dα _ _ _ xx yy zz1) ;; (xx ⊗⊗^{DT}_{l} (yy ⊗⊗^{DT}_{l} hh))
       =
       transportb
         _
         ((associatorlaw_natleft (monoidal_associatorlaw M)) x y z1 z2 h)
         (((xx ⊗⊗_{DT} yy) ⊗⊗^{DT}_{l} hh) ;; (dα _ _ _ xx yy zz2)).

  Definition disp_associator_nat_rightwhisker
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             (dα : disp_associator_data DT)
    : UU
    := ∏ (x1 x2 y z : C)
         (f : C⟦x1,x2⟧)
         (xx1 : D x1) (xx2 : D x2) (yy : D y) (zz : D z)
         (ff : xx1-->[f] xx2),
       (dα _ _ _ xx1 yy zz) ;; (ff ⊗⊗^{DT}_{r} (yy ⊗⊗_{DT} zz))
       =
       transportb
         _
         ((associatorlaw_natright (monoidal_associatorlaw M)) x1 x2 y z f)
         (((ff ⊗⊗^{DT}_{r} yy) ⊗⊗^{DT}_{r} zz) ;; (dα _ _ _ xx2 yy zz)).

  Definition disp_associator_nat_leftrightwhisker
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             (dα : disp_associator_data DT)
    : UU
    := ∏ (x y1 y2 z : C)
         (g : C⟦y1,y2⟧)
         (xx : D x) (yy1 : D y1) (yy2 : D y2) (zz : D z)
         (gg : yy1-->[g] yy2),
       (dα _ _ _ xx yy1 zz) ;; (xx ⊗⊗^{DT}_{l} (gg ⊗⊗^{DT}_{r} zz))
       =
       transportb
         _
         ((associatorlaw_natleftright (monoidal_associatorlaw M)) x y1 y2 z g)
         (((xx ⊗⊗^{DT}_{l} gg) ⊗⊗^{DT}_{r} zz) ;; (dα _ _ _ xx yy2 zz)).

  Definition disp_associator_nat'
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {dα : disp_associator_data DT}
             (dtl :  disp_associator_nat_leftwhisker dα)
             (dtr : disp_associator_nat_rightwhisker dα)
             (dtlr : disp_associator_nat_leftrightwhisker dα)
    : ∏ (x1 x2 y1 y2 z1 z2 : C)
        (xx1 : D x1) (xx2 : D x2)
        (yy1 : D y1) (yy2 : D y2)
        (zz1 : D z1) (zz2 : D z2)
        (f : C⟦x1,x2⟧)
        (g : C⟦y1,y2⟧)
        (h : C⟦z1,z2⟧)
        (ff : xx1-->[f] xx2)
        (gg : yy1 -->[g] yy2)
        (hh : zz1 -->[h] zz2),
       ((dα _ _ _ xx1 yy1 zz1) ;; (ff ⊗⊗^{DT} (gg ⊗⊗^{DT} hh)))
       =
       transportb
         _
         (associator_nat2
            M
            f g h)
         (((ff ⊗⊗^{DT} gg) ⊗⊗^{DT} hh) ;; dα _ _ _ xx2 yy2 zz2).
  Proof.
    intros.
    unfold dispfunctoronmorphisms1.
    etrans. { apply assoc_disp. }
    rewrite dtr.
    etrans. {
      apply maponpaths.
      apply mor_disp_transportf_postwhisker.
    }
    rewrite transport_b_f.
    apply transportf_transpose_left.
    etrans. { apply assoc_disp_var. }
    apply transportf_transpose_left.
    rewrite transport_b_b.
    rewrite transport_b_b.

    etrans. {
      apply maponpaths_1.
      apply maponpaths_1.
      apply disp_bifunctor_leftcomp.
    }
    etrans. {
      apply maponpaths.
      apply mor_disp_transportf_prewhisker.
    }
    etrans. {
      apply maponpaths_1.
      rewrite assoc_disp.
      rewrite dtlr.
      apply transport_f_b.
    }

    etrans. {
      apply maponpaths.
      apply maponpaths.
      apply mor_disp_transportf_postwhisker.
    }
    etrans. {
      apply maponpaths.
      apply transport_f_f.
    }
    etrans. { apply mor_disp_transportf_prewhisker. }
    apply transportf_transpose_left.

    etrans.
    {
      apply maponpaths_1.
      rewrite assoc_disp_var.
      apply maponpaths_1.
      apply maponpaths_1.
      apply dtl.
    }
    etrans. { apply mor_disp_transportf_prewhisker. }
    apply transportf_transpose_left.
    etrans. {
      apply maponpaths.
      apply mor_disp_transportf_prewhisker.
    }
    etrans. { apply mor_disp_transportf_prewhisker. }
    apply transportf_transpose_left.
    rewrite assoc_disp.
    etrans. {
      apply maponpaths.
      apply maponpaths_2.
      apply (pathsinv0
               (transportb_transpose_left
                  (disp_bifunctor_rightcomp DT _ _ _ _ _ _ _ _ _ _ _ _))).
    }
    rewrite transport_b_b.
    rewrite transport_b_b.
    rewrite transport_b_b.
    etrans. {
      apply maponpaths.
      apply mor_disp_transportf_postwhisker.
    }
    rewrite transport_b_f.
    apply transportf_transpose_left.
    rewrite transport_b_b.

    etrans. { apply assoc_disp. }
    apply transportb_transpose_left.

    use pathsinv0.
    rewrite transport_f_b.
    apply transportf_set.
    apply homset_property.
  Qed.

  Definition disp_associator_iso
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             (dα : disp_associator_data DT)
             (dαinv : disp_associatorinv_data DT)
    : UU
    := ∏ (x y z : C)
         (xx : D x)
         (yy : D y)
         (zz : D z),
       is_disp_inverse
         (pr222 (monoidal_associatorlaw M) x y z)
         (dα _ _ _ xx yy zz)
         (dαinv _ _ _ xx yy zz).

  Definition disp_associator_law
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             (dα : disp_associator_data DT)
             (dαinv : disp_associatorinv_data DT)
    : UU
    := (disp_associator_nat_leftwhisker dα)
       × (disp_associator_nat_rightwhisker dα)
       × (disp_associator_nat_leftrightwhisker dα)
       × (disp_associator_iso dα dαinv).

  Definition disp_associatorlaw_natleft
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {dα : disp_associator_data DT}
             {dαinv : disp_associatorinv_data DT}
             (dαl : disp_associator_law dα dαinv)
    : disp_associator_nat_leftwhisker dα
    := pr1 dαl.

  Definition disp_associatorlaw_natright
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {dα : disp_associator_data DT}
             {dαinv : disp_associatorinv_data DT}
             (dαl : disp_associator_law dα dαinv)
    : disp_associator_nat_rightwhisker dα
    := pr12 dαl.

  Definition disp_associatorlaw_natleftright
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {dα : disp_associator_data DT}
             {dαinv : disp_associatorinv_data DT}
             (dαl : disp_associator_law dα dαinv)
    : disp_associator_nat_leftrightwhisker dα
    := pr122 dαl.

  Definition disp_associatorlaw_iso
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {dα : disp_associator_data DT}
             {dαinv : disp_associatorinv_data DT}
             (dαl : disp_associator_law dα dαinv)
    : disp_associator_iso dα dαinv
    := pr222 dαl.

  Definition disp_triangle_identity
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             {i : D I_{M}}
             (dlu : disp_leftunitor_data DT i)
             (dru : disp_rightunitor_data DT i)
             (dα : disp_associator_data DT)
    : UU
    := ∏ (x y : C) (xx : D x) (yy : D y),
       ((dα x I_{M} y xx i yy) ;; (xx ⊗⊗^{DT}_{l} dlu y yy ))
       =
       transportb
         _
         ((monoidal_triangleidentity M) x y)
         ((dru x xx) ⊗⊗^{DT}_{r} yy).

  Definition disp_pentagon_identity
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             {DT : disp_tensor D M}
             (dα : disp_associator_data DT)
    : UU
    := ∏ (w x y z : C)
         (ww : D w)
         (xx : D x)
         (yy : D y)
         (zz : D z),
       ((dα _ _ _ ww xx yy) ⊗⊗^{DT}_{r} zz)
       ;; (dα _ _ _ ww (xx ⊗⊗_{DT} yy) zz)
       ;; (ww ⊗⊗^{DT}_{l} (dα _ _ _ xx yy zz))
       =
       transportb
         _
         ((monoidal_pentagonidentity M) w x y z)
         ((dα _ _ _ (ww ⊗⊗_{DT} xx) yy zz) ;; (dα _ _ _ ww xx (yy ⊗⊗_{DT} zz))).

  Definition disp_monoidal_laws
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DMD :  disp_monoidal_data D M)
    : UU
    := (disp_leftunitor_law dlu_{DMD} dluinv_{DMD})
       × (disp_rightunitor_law dru_{DMD} druinv_{DMD})
       × (disp_associator_law dα_{DMD} dαinv_{DMD})
       × (disp_triangle_identity dlu_{DMD} dru_{DMD} dα_{DMD})
       × (disp_pentagon_identity dα_{DMD}).

  Definition disp_monoidal
             {C : category}
             (D : disp_cat C)
             (M : monoidal C)
    : UU
    := ∑ (MD : disp_monoidal_data D M), (disp_monoidal_laws MD).

  Definition disp_monoidal_mondata
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_monoidal_data D M
    := pr1 DM.

  Coercion disp_monoidal_mondata : disp_monoidal >-> disp_monoidal_data.

  Definition disp_monoidal_monlaws
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_monoidal_laws DM
    := pr2 DM.

  Definition disp_monoidal_leftunitorlaw
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_leftunitor_law dlu_{DM} dluinv_{DM}
    := pr1 (disp_monoidal_monlaws DM).

  Definition disp_monoidal_leftunitornat
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_leftunitor_nat dlu_{DM}
    := disp_leftunitorlaw_nat (disp_monoidal_leftunitorlaw DM).

  Definition disp_monoidal_leftunitoriso
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_leftunitor_iso dlu_{DM} dluinv_{DM}
    := disp_leftunitorlaw_iso (disp_monoidal_leftunitorlaw DM).

  Definition disp_monoidal_rightunitorlaw
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_rightunitor_law dru_{DM} druinv_{DM}
    := pr12 (disp_monoidal_monlaws DM).

  Definition disp_monoidal_rightunitornat
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_rightunitor_nat dru_{DM}
    := disp_rightunitorlaw_nat (disp_monoidal_rightunitorlaw DM).

  Definition disp_monoidal_rightunitoriso
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_rightunitor_iso dru_{DM} druinv_{DM}
    := disp_rightunitorlaw_iso (disp_monoidal_rightunitorlaw DM).

  Definition disp_monoidal_associatorlaw
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_associator_law dα_{DM} dαinv_{DM}
    := pr122 (disp_monoidal_monlaws DM).

  Definition disp_monoidal_associatornatleft
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_associator_nat_leftwhisker dα_{DM}
    := disp_associatorlaw_natleft (disp_monoidal_associatorlaw DM).

  Definition disp_monoidal_associatornatright
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_associator_nat_rightwhisker dα_{DM}
    := disp_associatorlaw_natright (disp_monoidal_associatorlaw DM).

  Definition disp_monoidal_associatornatleftright
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_associator_nat_leftrightwhisker dα_{DM}
    := disp_associatorlaw_natleftright (disp_monoidal_associatorlaw DM).

  Definition disp_monoidal_associatoriso
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_associator_iso dα_{DM} dαinv_{DM}
    := disp_associatorlaw_iso (disp_monoidal_associatorlaw DM).

  Definition disp_monoidal_triangleidentity
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_triangle_identity dlu_{DM} dru_{DM} dα_{DM}
    := pr1 (pr222 (disp_monoidal_monlaws DM)).

  Definition disp_monoidal_pentagonidentity
             {C : category}
             {D : disp_cat C}
             {M : monoidal C}
             (DM : disp_monoidal D M)
    : disp_pentagon_identity dα_{DM}
    := pr2 (pr222 (disp_monoidal_monlaws DM)).

  Lemma isaprop_disp_monoidal_laws
        {C : category}
        {D : disp_cat C}
        {M : monoidal C}
        (DM : disp_monoidal_data D M)
    : isaprop (disp_monoidal_laws DM).
  Proof.
    repeat (apply isapropdirprod)
    ; repeat (apply impred ; intro)
    ; repeat (try apply D)
    ; repeat (apply isaprop_is_disp_inverse).
  Qed.
End DisplayedMonoidalCategories.

Module DisplayedMonoidalNotations.
  Notation "dI_{ M }" := (disp_monoidal_unit M).
  Notation "dlu^{ M }" := (disp_monoidal_leftunitor M).
  Notation "dru^{ M }" := (disp_monoidal_rightunitor M).
  Notation "dα^{ M }" := (disp_monoidal_associator M).

  Notation "dluinv^{ M }" := (disp_monoidal_leftunitorinv M).
  Notation "druinv^{ M }" := (disp_monoidal_rightunitorinv M).
  Notation "dαinv^{ M }" := (disp_monoidal_associatorinv M).

  Notation "dlu^{ M }_{ xx }" := (disp_monoidal_leftunitor M _ xx).
  Notation "dru^{ M }_{ xx }" := (disp_monoidal_rightunitor M _ xx).
  Notation "dα^{ M }_{ xx , yy , zz }" := (disp_monoidal_associator M _ _ _ xx yy zz).

  Notation "dluinv^{ M }_{ xx }" := (disp_monoidal_leftunitorinv M _ xx).
  Notation "druinv^{ M }_{ xx }" := (disp_monoidal_rightunitorinv M _ xx).
  Notation "dαinv^{ M }_{ xx , yy , zz }" := (disp_monoidal_associatorinv M _ _ _ xx yy zz).
End DisplayedMonoidalNotations.


From QuickChick Require Import QuickChick Tactics TacticsUtil Instances
     Classes DependentClasses Sets EnumProofs.

Require Import String. Open Scope string.
Require Import List micromega.Lia.

From Ltac2 Require Import Ltac2.

Import ListNotations.
Import QcDefaultNotation. Open Scope qc_scope.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

Set Bullet Behavior "Strict Subproofs".

(** Examples *)

Inductive tree A : Type :=
| Leaf : A -> tree A
| Leaf' : A -> A -> tree A
| Node : A -> tree A -> tree A -> tree A.

Derive EnumSized for tree.

Instance EnumTree_SizedMonotonic A {_ : Enum A} :
  SizedMonotonic (@enumSized _ (@EnumSizedtree A _)).
Proof. derive_enum_SizedMonotonic (). Qed.

Instance EnumTree_SizeMonotonic A `{EnumMonotonic A} :
  forall s, SizeMonotonic (@enumSized _ (@EnumSizedtree A _) s).
Proof. derive_enum_SizeMonotonic (). Qed.

Instance EnumTree_correct A `{EnumMonotonicCorrect A} :
  CorrectSized (@enumSized _ (@EnumSizedtree A _)).
Proof. derive_enum_Correct (). Qed.

Inductive Foo : Type :=
| Bar.

Derive EnumSized for Foo.

Instance EnumFoo_SizedMonotonic :
  SizedMonotonic (@enumSized _ EnumSizedFoo).
Proof. derive_enum_SizedMonotonic (). Qed.

Instance EnumFoo_SizeMonotonic :
  forall s, SizeMonotonic (@enumSized _ EnumSizedFoo s).
Proof. derive_enum_SizeMonotonic (). Qed.

Instance EnumFoo_correct :
  CorrectSized (@enumSized _ EnumSizedFoo).
Proof. derive_enum_Correct (). Qed.

Inductive Foo2 A : Type :=
| Bar1
| Bar2 : A -> Foo2 A.

Derive EnumSized for Foo2.

Instance EnumFoo2_SizedMonotonic A {_ : Enum A} :
  SizedMonotonic (@enumSized _ (@EnumSizedFoo2 A _)).
Proof. derive_enum_SizedMonotonic (). Qed.

Instance EnumFoo2_SizeMonotonic A `{EnumMonotonic A} :
  forall s, SizeMonotonic (@enumSized _ (@EnumSizedFoo2 A _) s).
Proof. derive_enum_SizeMonotonic (). Qed.

Instance EnumFoo2_correct A `{EnumMonotonicCorrect A} :
  CorrectSized (@enumSized _ (@EnumSizedFoo2 A _)).
Proof. derive_enum_Correct (). Qed.

(* Example with two IH *)
Inductive goodTree : nat -> tree nat  -> Prop :=
| GL : goodTree 0 (Leaf nat 0)
| GN :
    forall k t1 t2 n m,
      goodTree n t1 ->
      goodTree m t2 ->
      goodTree m t1 ->
      goodTree (S n) (Node nat k t1 t2).