(** Fragmento Implicacional da Lógica Proposicional Intuicionista **)

(** Dicas:

    intro: introdução da implicação
    exact H: a hipótese H corresponde exatamente ao que se quer provar.
    assumption: o que se quer provar é igual a alguma das hipóteses.
    apply H: o tipo alvo de H coincide com o que se quer provar.
    inversion H: aplica o(s) construtor(es) que permitem gerar a hipótese H. Se nenhum construtor pode ser aplicado, a prova é concluída. Também permite concluir que a partir do absurdo (False) se prova qualquer coisa.

*)

(**
   Nos exercícios abaixos remova o comando 'Admitted' e construa uma prova para as proposições apresentadas.
 *)

Section Exercicios1.
Variables A B C D: Prop.

Lemma exercicio1 : A -> B -> A.
Proof.
intros A1 B1.
assumption.

Qed.

Lemma exercicio2 : (A -> B -> C) -> (A -> B) -> A -> C.
Proof.

intros func1 func2 A1.

apply func1.

assumption.

apply func2.

exact A1.

Qed.

Lemma exercicio3 : (A -> B) -> (C -> A) -> C -> B.
Proof.

intros func1 func2 C1.
apply func1.
apply func2.
exact C1.

Qed.

Lemma exercicio4 : (A -> B -> C) -> B -> A -> C.
Proof.

intros func1 B1 A1.
apply func1.
exact A1.
exact B1.

Qed.

Lemma exercicio5 : ((((A -> B) -> A) -> A) -> B) -> B.
Proof.

intros func1.
apply func1.
intros func2.
apply func2.
intros A1.
apply func1.
intros func3.
exact A1.

Qed.

Lemma exercicio6: (A -> B) -> (B -> C) -> A -> C.
Proof.

intros func1 func2 A1.
apply func2.
apply func1.
exact A1.

Qed.

Lemma exercicio7: (A -> B -> C) -> (B -> A -> C).
Proof.

intros func1 func2.
intros A1.
apply func1.
exact A1.
exact func2.

Qed.

Lemma exercicio8: (A -> C) -> A -> B -> C.
Proof.
Admitted.

Lemma exercicio9: (A -> A -> B) -> A -> B.
Proof.
Admitted.

Lemma exercicio10:  (A -> B) -> (A -> A -> B).
Proof.
Admitted.

Lemma exercicio11: (A -> B) -> (A -> C) -> (B -> C -> D) -> A -> D.
Proof.
Admitted.

Lemma exercicio12: ((((A -> B) -> A) -> A) -> B) -> B.
Proof.
Admitted.

Lemma exercicio13: False -> A.
Proof.
  intro H.
  inversion H.
Qed.

Lemma conj_imp: (A -> B -> C) <-> ((A /\ B ) -> C).
Proof.
  split.
  - admit.
  - Admitted.

(**
proof identation
http://poleiro.info/posts/2013-06-27-structuring-proofs-with-bullets.html
http://prl.ccs.neu.edu/blog/2017/02/21/bullets-are-good-for-your-coq-proofs/
https://coq.inria.fr/refman/proof-engine/proof-handling.html
*)

End Exercicios1.

Section Exercicios2.
Variable P: Prop.
Lemma id_p: P -> P.
Proof.
  intro H.
  assumption.
Qed.

Print id_p.

Lemma id_p'': P -> P.
Proof.
  exact (fun x:P => x).
Qed.

End Exercicios2.

Theorem id_p': forall P, P -> P.
Proof.
  intros P.
  intros P1.
  assumption.
Qed.

Print id_p'.

Theorem id_p''': forall P:Prop, P -> P.
Proof.
  exact (fun (P:Prop) (x:P) => x).
Qed.

Print id_p'.

Lemma id_PP: forall P, (P -> P) -> (P -> P).
Proof.
  intros P p1 p2.
  assumption.
Qed.

Print id_PP.

Lemma id_PP': forall P, (P -> P) -> (P -> P).
Proof.
  exact (fun (P:Type) (x : P -> P) => x).
Qed.

Print id_PP'.

Lemma imp_trans: forall P Q R, (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P.
  intros Q.
  intros R.
  intros func1.
  intros func2.
  intros Papp.
  pose (Qapp := func1 Papp).
  pose (Rapp := func2 Qapp).
  assumption.
Qed.

Lemma imp_trans_ref: forall P Q R, (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P.
  intros Q.
  intros R.
  intros func1.
  intros func2.
  intros Papp.
  refine (func2 _).
  refine (func1 _).
  assumption.
Qed.

Lemma imp_perm : forall P Q R, (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros P Q R.
  intros func1.
  intros Qapp.
  intros Papp.
  pose (QRapp := func1 Papp).
  pose (Rapp := QRapp Qapp).
  assumption.
Qed.

Lemma ignore_Q : forall P Q R, (P -> R) -> P -> Q -> R.
Proof.
  intros P Q R.
  intros func1.
  intros Papp.
  intros Qapp.
  pose (Rapp := func1 Papp).
  assumption.
Qed.

Lemma ignore_Q_without_parenthesis : forall P Q R, P -> R -> P -> Q -> R.
Proof.
  intros P Q R.
  intros Papp Rapp Papp2 Qapp1.
  assumption.
Qed.

Lemma delta_imp : forall P Q, (P -> P -> Q) -> P -> Q.
Proof.
  intros P Q.
  intros func1.
  intros Papp.
  pose (PQapp := func1 Papp).
  pose (Qapp := PQapp Papp).
  assumption.
Qed.

Lemma delta_impR : forall P Q, (P->Q)->(P->P->Q).
Proof.
  intros P Q.
  intros func1.
  intros Papp.
  intros Papp2.
  pose (Qapp := func1 Papp).
  assumption.
Qed.

Lemma delta_impR' : forall P Q, (P->Q)->(P->P->Q).
Proof.
  intros P Q.
  intros func1.
  intros Papp.
  intros Papp2.
  apply func1.
  assumption.
Qed.

Lemma diamond : forall P Q R T, (P->Q)->(P->R)->(Q->R->T)->P->T.
Proof.
  intros P Q R T.
  intros func1.
  intros func2.
  intros func3.
  intros Papp.
  pose (Qapp := func1 Papp).
  pose (Rapp := func2 Papp).
  pose (RTapp := func3 Qapp).
  pose (Tapp := RTapp Rapp).
  assumption.
Qed.

Lemma weak_peirce : forall P Q, ((((P->Q)->P)->P)->Q)->Q.
Proof.
  intros P Q.
  intros func1.
  apply func1.
  intro func2.
  apply func2.
  intro func3.
  apply func1.
  intro func4.
  exact func3.
Qed.

Print weak_peirce.


From Undecidability.Shared.Libs.PSL Require Import FinTypes.

Definition Cardinality (F: finType) := | elem F |.

(* * Dupfreeness *)
(* Proofs about dupfreeness *)

Lemma dupfree_countOne (X: eqType) (A: list X) : (forall x, count A x <= 1) -> dupfree A.
Proof.
  induction A.
  - constructor.
  - intro H. constructor.
    + cbn in H.  specialize (H a). deq a. assert (count A a = 0) by lia. now apply countZero.
    + apply IHA. intro x. specialize (H x). cbn in H. dec; lia.
Qed.

Lemma dupfree_elements (X: finType) : dupfree (elem X).
Proof.
  destruct X as [X [A AI]]. assert (forall x, count A x <= 1) as H'.
  {
    intro x. specialize (AI x). lia.
  }
  now apply dupfree_countOne.
Qed.

Lemma dupfree_length (X: finType) (A: list X) : dupfree A -> |A| <= Cardinality X.
Proof.
  unfold Cardinality.  intros D.
  rewrite <- (dupfree_card D). rewrite <- (dupfree_card (dupfree_elements X)).
  apply card_le. apply allSub.
Qed.

Lemma disjoint_concat X (A: list (list X)) (B: list X) : (forall C, C el A -> disjoint B C) -> disjoint B (concat A).
Proof.
  intros H. induction A.
  - cbn. auto.
  - cbn. apply disjoint_symm. apply disjoint_app. split; auto using disjoint_symm.
Qed.

Lemma dupfree_concat (X: Type) (A: list (list X)) : (forall B, B el A -> dupfree B) /\ (forall B C, B <> C -> B el A -> C el A -> disjoint B C) -> dupfree A -> dupfree (concat A).
Proof.
  induction A.
  - constructor.
  - intros [H H'] D. cbn. apply dupfree_app.
    + apply disjoint_concat. intros C E. apply H'; auto. inv D. intro G; apply H2. now subst a.
    + now apply H.
    + inv D; apply IHA; auto.
Qed.

(* (* * Proofs about Cardinality *) *)

(* Lemma Card_positiv (X: finType) (x:X) : Cardinality X > 0. *)
(* Proof. *)
(*   pose proof (elem_spec x).  unfold Cardinality.  destruct (elem X). *)
(*   - contradiction H. *)
(*   - cbn. lia. *)
(* Qed.  *)

(* Lemma Cardinality_card_eq (X: finType): card (elem X) = Cardinality X. *)
(* Proof. *)
(*   apply dupfree_card. apply dupfree_elements. *)
(* Qed. *)

(* Lemma card_upper_bound (X: finType) (A: list X): card A <= Cardinality X. *)
(* Proof. *)
(*  rewrite <-  Cardinality_card_eq. apply card_le. apply allSub. *)
(* Qed.   *)

(* Lemma injective_dupfree (X: finType) (Y: Type) (A: list X) (f: X -> Y) : injective f -> dupfree (getImage f). *)
(* Proof. *)
(*   intro inj. unfold injective in inj. *)
(*   unfold getImage. apply dupfree_map. *)
(*   - firstorder. *)
(*   - apply dupfree_elements. *)
(* Qed. *)

(* Theorem pidgeonHole_inj (X Y: finType) (f: X -> Y) (inj: injective f): Cardinality X <= Cardinality Y. *)
(* Proof. *)
(*   rewrite <- (getImage_length f). apply dupfree_length. apply (injective_dupfree (elem X) inj). *)
(* Qed. *)

(* Lemma surj_sub (X Y: finType) (f: X -> Y) (surj: surjective f): elem Y <<= getImage f. *)
(* Proof. *)
(* intros y E. specialize (surj y). destruct surj as [x H]. subst y. apply getImage_in. *)
(* Qed. *)

(* Theorem pidgeonHole_surj (X Y: finType) (f: X -> Y) (surj: surjective f): Cardinality X >= Cardinality Y. *)
(* Proof. *)
(*   rewrite <- (getImage_length f). rewrite <- Cardinality_card_eq. *)
(*     pose proof (card_le (surj_sub surj)) as H. pose proof (card_length_leq (getImage f)) as H'. lia. *)
(* Qed. *)

(* Lemma eq_iff (x y: nat) : x >= y /\ x <= y -> x = y. *)
(* Proof. *)
(*   lia. *)
(* Qed. *)

(* Corollary pidgeonHole_bij (X Y: finType) (f: X -> Y) (bij: bijective f): *)
(*   Cardinality X = Cardinality Y. *)
(* Proof. *)
(*   destruct bij as [inj surj]. apply eq_iff. split. *)
(*   - now eapply pidgeonHole_surj. *)
(*   - eapply pidgeonHole_inj; eauto. *)
(* Qed.     *)

(* Lemma Prod_Card (X Y: finType) : Cardinality (X (x) Y) = Cardinality X * Cardinality Y. *)
(* Proof. *)
(*   cbn.  unfold prodLists. unfold Cardinality. induction (elem X).  *)
(*   - reflexivity. *)
(*   - cbn. rewrite app_length. rewrite IHl. f_equal. apply map_length. *)
(* Qed.     *)

(* Lemma Option_Card (X: finType) : Cardinality (? X) = S(Cardinality X). *)
(* Proof. *)
(*   cbn. now rewrite map_length. *)
(* Qed. *)

(* Lemma SumCard (X Y: finType) : Cardinality (finType_sum X Y) = Cardinality X + Cardinality Y. *)
(* Proof. *)
(*   unfold Cardinality. cbn. rewrite app_length. unfold toSumList1, toSumList2. now  repeat rewrite map_length. *)
(* Qed. *)

(* Lemma extPow_length X Y L P: |@extensionalPower X Y L P| = | L |. *)
(* Proof. *)
(*   induction L. *)
(*   -  reflexivity. *)
(*   - simpl. f_equal. apply IHL. *)
(* Qed. *)

(* Lemma concat_map_length (X: Type) (A: list X) (B: list (list X)) : *)
(* | concat (map (fun x => map (cons x) B) A) |= |A| * |B|. *)
(* Proof. *)
(*   induction A. *)
(*   - reflexivity. *)
(*   - cbn. rewrite app_length. rewrite map_length. congruence. *)
(* Qed.     *)

(* Lemma images_length Y (A: list Y) n : |images A n| = (|A| ^ n)%nat. *)
(* Proof. *)
(*   induction n. *)
(*   - reflexivity. *)
(*   - cbn. rewrite concat_map_length.  now rewrite IHn. *)
(* Qed. *)

(* Lemma Vector_Card (X Y: finType): Cardinality (Y ^ X) = (Cardinality Y ^ (Cardinality X ))%nat. *)
(* Proof. *)
(*   cbn. rewrite extPow_length. now rewrite images_length. *)
(* Qed. *)


(* The Universe contains 'Things.', for example: "I", "London", etc. *)
Parameter U: Set.

(* existence is affirmed or denied, is regarded as the Predicate *)
Definition Predicate := U -> Prop.

(*
A 'Proposition', when in normal form, asserts, as to certain two Classes, which are called its 'Subject' and 'Predicate', either

that some Members of its Subject are Members of its Predicate;

or that no Members of its Subject are Members of its Predicate;

or that all Members of its Subject are Members of its Predicate.

*)

(* All Members of its Subject are Members of its Predicate; Proposition in A *)
Notation "'All' subject 'are' predicate" := (forall x:U, subject(x) -> predicate(x)) (at level 50).
Notation "'All' subject 'is' predicate" := (forall x:U, subject(x) -> predicate(x)) (at level 50).

(* No Members of its Subject are Members of its Predicate; Proposition in E *)
Notation "'No' subject 'are' predicate" := (forall x:U, subject(x) -> ~predicate(x)) (at level 50).
Notation "'No' subject 'is' predicate" := (forall x:U, subject(x) -> ~predicate(x)) (at level 50).

(* Some Members of its Subject are Members of its Predicate; Proposition in I *)
Notation "'Some' subject 'are' predicate" := (exists x:U, subject(x) /\ predicate(x)) (at level 50).
Notation "'Some' subject 'are' 'not' predicate" := (exists x:U, subject(x) /\ ~predicate(x)) (at level 50).

Axiom contraposition: forall subject predicate: Predicate, (No subject are predicate) -> (No predicate are subject).
Axiom doubleneg: forall p: Prop, ~~p->p.

Parameter selfish popular helpful: Predicate.
Axiom A1: No selfish is popular.
Axiom A2: All helpful is popular.
Theorem T1: No selfish is helpful.
  intros.
  apply A1 in H.
  contradict H.
  apply A2.
  assumption.
Qed.

Parameter soldiers valiant brave: Predicate.
Axiom A3: All soldiers are valiant.
Axiom A4: Some soldiers are brave.
Theorem T2: Some valiant are brave.
Proof.
  destruct A4.
  destruct H.
  apply A3 in H.
  exists x.
  split.
  assumption.
  assumption.
Qed.

Parameter my_uncles generous gourmet: Predicate.
Axiom A5: No gourmet is generous.
Axiom A6: All my_uncles are generous.
Theorem T3: No my_uncles are gourmet.
  intros.
  apply A6 in H.
  contradict H.
  apply A5.
  assumption.
Qed.

Parameter cats understanding_French chickens: Predicate.
Axiom A7: All cats are understanding_French.
Axiom A8: Some chickens are cats.
Theorem T4: Some chickens are understanding_French.
destruct A8.
destruct H as [a b].
apply A7 in b.
exists x.
tauto.
Qed.

(*
'To begin with,' said the Cat, 'a dog's not mad. You grant that?'
'I suppose so,' said Alice.
'Well, then,' the Cat went on,*
'you see, a dog growls when it's angry, and wags its tail when it's pleased.
Now I growl when I'm pleased, and wag my tail when I'm angry.
Therefore I'm mad.'
*)
Parameter mad cat dogs angry: Predicate.
Axiom A9: No dogs are mad.
(* TODO finish Alice speaks to Cheshire Cat *)


Require Export Coq.Unicode.Utf8.
Require Export FOmega.

(******************************************************************************)
(* Kinding relation                                                           *)
(******************************************************************************)

Inductive Kinding (Γ : Env) : Ty → Kind → Prop :=
  | K_TVar {X K} :
      lookup_etvar Γ X K → Kinding Γ (tvar X) K
  | K_Abs {K1 K2 T2} :
      Kinding (etvar Γ K1) T2 K2 →
      Kinding Γ (tabs K1 T2) (karr K1 K2)
  | K_App {K11 K12 T1 T2} :
      Kinding Γ T1 (karr K11 K12) → Kinding Γ T2 K11 →
      Kinding Γ (tapp T1 T2) K12
  | K_Arr {T1 T2} :
      Kinding Γ T1 star → Kinding Γ T2 star →
      Kinding Γ (tarr T1 T2) star
  | K_All {K1 T2} :
      Kinding (etvar Γ K1) T2 star →
      Kinding Γ (tall K1 T2) star.

(******************************************************************************)
(* Type equivalence relation.                                                 *)
(******************************************************************************)

Inductive TyEq (Γ : Env) : Ty → Ty → Kind → Prop :=
  | Q_Arrow {S1 T1 S2 T2} :
      TyEq Γ S1 T1 star → TyEq Γ S2 T2 star →
      TyEq Γ (tarr S1 S2) (tarr T1 T2) star
  | Q_Abs {K1 K2 S2 T2} :
      TyEq (etvar Γ K1) S2 T2 K2 →
      TyEq Γ (tabs K1 S2) (tabs K1 T2) (karr K1 K2)
  | Q_App {K1 K2 S1 T1 S2 T2} :
      TyEq Γ S1 T1 (karr K1 K2) → TyEq Γ S2 T2 K1 →
      TyEq Γ (tapp S1 S2) (tapp T1 T2) K2
  | Q_All {K1 S2 T2} :
      TyEq (etvar Γ K1) S2 T2 star →
      TyEq Γ (tall K1 S2) (tall K1 T2) star
  | Q_AppAbs {K11 K12 T12 T2} :
      Kinding (etvar Γ K11) T12 K12 → Kinding Γ T2 K11 →
      TyEq Γ (tapp (tabs K11 T12) T2) (tsubstTy X0 T2 T12) K12
  | Q_Refl {T K} :
      Kinding Γ T K → TyEq Γ T T K
  | Q_Symm {T S K} :
      TyEq Γ T S K → TyEq Γ S T K
  | Q_Trans {S U T K} :
      TyEq Γ S U K → TyEq Γ U T K → TyEq Γ S T K.

(******************************************************************************)
(* Typing relation.                                                           *)
(******************************************************************************)

Inductive Typing (Γ : Env) : Tm → Ty → Prop :=
  | T_Var {y T} :
      lookup_evar Γ y T → Typing Γ (var y) T
  | T_Abs {t T1 T2} :
      Kinding Γ T1 star → Typing (evar Γ T1) t T2 →
      Typing Γ (abs T1 t) (tarr T1 T2)
  | T_App {t1 t2 T11 T12} :
      Typing Γ t1 (tarr T11 T12) → Typing Γ t2 T11 →
      Typing Γ (app t1 t2) T12
  | T_TAbs {K t T} :
      Typing (etvar Γ K) t T →
      Typing Γ (tyabs K t) (tall K T)
  | T_TApp {t1 K11 T12 T2} :
      Typing Γ t1 (tall K11 T12) → Kinding Γ T2 K11 →
      Typing Γ (tyapp t1 T2) (tsubstTy X0 T2 T12)
  | T_Eq {t S T} :
      Typing Γ t S → TyEq Γ S T star →
      Typing Γ t T.

(******************************************************************************)
(* Type reduction relation.                                                   *)
(******************************************************************************)

Inductive TRed (Γ : Env) : Ty → Ty → Kind → Prop :=
  | QR_Var {X K} :
      lookup_etvar Γ X K →
      TRed Γ (tvar X) (tvar X) K
  | QR_Arrow {S1 T1 S2 T2} :
      TRed Γ S1 T1 star → TRed Γ S2 T2 star →
      TRed Γ (tarr S1 S2) (tarr T1 T2) star
  | QR_Abs {S2 T2 K1 K2} :
      TRed (etvar Γ K1) S2 T2 K2 →
      TRed Γ (tabs K1 S2) (tabs K1 T2) (karr K1 K2)
  | QR_App {S1 T1 S2 T2 K1 K2} :
      TRed Γ S1 T1 (karr K2 K1) → TRed Γ S2 T2 K2 →
      TRed Γ (tapp S1 S2) (tapp T1 T2) K1
  | QR_All {K1 S2 T2} :
      TRed (etvar Γ K1) S2 T2 star →
      TRed Γ (tall K1 S2) (tall K1 T2) star
  | QR_AppAbs {S1 T1 S2 T2 K1 K2} :
      TRed (etvar Γ K2) S1 T1 K1 → TRed Γ S2 T2 K2 →
      TRed Γ (tapp (tabs K2 S1) S2) (tsubstTy X0 T2 T1) K1.

Inductive TRedStar (Γ : Env) : Ty → Ty → Kind → Prop :=
  | QRS_Nil {T K} :
      Kinding Γ T K → TRedStar Γ T T K
  | QRS_Cons {S T U K} :
      TRedStar Γ S T K → TRed Γ T U K → TRedStar Γ S U K.


Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.Strings.String.

(* Syntax of Clock-based Dynamic Logic *)

(* Syntax of SEP_exp (Synchonous Event Program) *)

(* ========================= Syntax of SEP_exp ========================*)

(* =============== Syntax of Expressions ===================*)

(* Arith Expression `e'*)
Inductive e_exp :=
  enumC : nat -> e_exp |
  evarC : string -> e_exp |
  eplusC : e_exp -> e_exp -> e_exp |
  (*non-necessary expression*)
  eminusC : e_exp -> e_exp -> e_exp |
  emulC : e_exp -> e_exp -> e_exp |
  edivC : e_exp -> e_exp -> e_exp
.
Print e_exp.

Notation "e1 '+ e2" := (eplusC e1 e2) (at level 31, right associativity).
Locate "'+".
Notation "e1 '- e2" := (eminusC e1 e2) (at level 31, right associativity).

Notation "e1 '* e2" := (emulC e1 e2) (at level 21, right associativity).

(*** Open Scope e_exp_scope. ***)

Locate "*".
Check (enumC 4) '* (enumC 5 '+ enumC 6).

Notation "e1 '/ e2" := (edivC e1 e2) (at level 21, right associativity).
Check (enumC 4) '/ (enumC 4).

Coercion enumC : nat >-> e_exp.
Coercion evarC : string >-> e_exp.
Definition x : string := "x".
Definition y : string := "y".
Definition z : string := "z".
Definition k : string := "k".

Check 4 '* (5 '+ 2).
Check (5 '+ 4) '* 8.
Check x '- 3.
Check 5 '+ 4 '* 5.

(* Boolean Expression `P'*)
Inductive P_exp :=
  PtrueC : P_exp |
  PlteC : e_exp -> e_exp -> P_exp |
  PnegC : P_exp -> P_exp |
  PandC : P_exp -> P_exp -> P_exp |
  (*non-necesarry expression*)
  PfalseC : P_exp |
  PltC : e_exp -> e_exp -> P_exp |
  PgtC : e_exp -> e_exp -> P_exp |
  PgteC : e_exp -> e_exp -> P_exp |
  PeqC : e_exp -> e_exp -> P_exp |
  PorC : P_exp -> P_exp -> P_exp |
  PimpC : P_exp -> P_exp -> P_exp
.
Print P_exp.

(* 33 - 41 *)
Notation "''tt'" := PtrueC (at level 35).
Notation "e1 '<= e2" := (PlteC e1 e2) (at level 33).
Notation "'~ P" := (PnegC P) (at level 36).
Notation "P1 '/\ P2" := (PandC P1 P2) (at level 37, right associativity).
Notation "''ff'" := PfalseC (at level 35).
Notation "e1 '< e2" := (PltC e1 e2) (at level 33).
Notation "e1 '> e2" := (PgtC e1 e2) (at level 33).
Notation "e1 '>= e2" := (PgteC e1 e2) (at level 33).
Notation "e1 '= e2" := (PeqC e1 e2) (at level 33).
Notation "P1 '\/ P2" := (PorC P1 P2) (at level 37, right associativity).
Notation "P1 '-> P2" := (PimpC P1 P2) (at level 38, right associativity).

Locate "'/\".
Check 'tt '-> 'ff.
Check 5 '+ x '>= 5 '-> 3 '> 7.

(* Evaluation *)
Definition state := string -> nat.

(***
  Definging the evaluation for expressions is for checking the validation of FOL formulas after
  transformation.
***)

Fixpoint eval_e_exp (e : e_exp) (st : state) : nat :=
(* st maps each var name to a value --- it is a state *)
  match e with
  | enumC n => n
  | evarC s => st s
  | eplusC e1 e2 => (eval_e_exp e1 st) + (eval_e_exp e2 st)
  | eminusC e1 e2 => (eval_e_exp e1 st) - (eval_e_exp e2 st)
  | emulC e1 e2 => (eval_e_exp e1 st) * (eval_e_exp e2 st)
  | edivC e1 e2 => (eval_e_exp e1 st) / (eval_e_exp e2 st)
  end.

Fixpoint eval_P_exp (P : P_exp) (st : state) : Prop :=
  match P with
  | PtrueC => True
  | PlteC e1 e2 => (eval_e_exp e1 st) <= (eval_e_exp e2 st)
  | PnegC P' => ~ (eval_P_exp P' st)
  | PandC P1 P2 => (eval_P_exp P1 st) /\ (eval_P_exp P1 st)
  | PfalseC => False
  | PltC e1 e2 => (eval_e_exp e1 st) < (eval_e_exp e2 st)
  | PgtC e1 e2 => (eval_e_exp e1 st) > (eval_e_exp e2 st)
  | PgteC e1 e2 => (eval_e_exp e1 st) >= (eval_e_exp e2 st)
  | PeqC e1 e2 => (eval_e_exp e1 st) = (eval_e_exp e2 st)
  | PorC P1 P2 => (eval_P_exp P1 st) \/ (eval_P_exp P1 st)
  | PimpC P1 P2 => (eval_P_exp P1 st) -> (eval_P_exp P1 st)
  end.

(* =============== Syntax of Event ===================*)

(* Event *)
Inductive EvtElement :=
  sigC : string -> e_exp -> EvtElement | (* Signal *)
  assC : string -> e_exp -> EvtElement  (* Assignment *)
.
Check EvtElement.

Notation "s ! e" := (sigC s e) (at level 45).
Notation "x :=' e" := (assC x e) (at level 45).

(* currently we do not make distinguish between variable and clock names, both are strings*)
Definition c : string := "c".
Definition d : string := "d".
Definition c1 : string := "c1".
Definition c2 : string := "c2".
Definition c3 : string := "c3".
Definition c4 : string := "c4".

Check x :=' 4.
Check c ! (x '+ 4).

Definition Evt := list EvtElement.

Check Evt.
Check (x :=' 4) :: (c!(x '+ 4)) :: nil.

(* ========================= Syntax of program ========================*)
Inductive SEP_exp : Type :=
  skip : SEP_exp | (* skip program $\varepsilon$ *)
  evtC : Evt -> SEP_exp | (* Event *)
  tstC : P_exp -> Evt -> SEP_exp | (* Test *)
  seqC : SEP_exp -> SEP_exp -> SEP_exp | (* sequence *)
  choC : SEP_exp -> SEP_exp -> SEP_exp | (* choice *)
  loopC : SEP_exp -> SEP_exp (* loop *)
.

Notation "{ a1 | .. | an }" := (cons a1 .. (cons an nil) .. ) (at level 45).
Notation "@ a" := (evtC a) (at level 46).
Definition idle : Evt := nil.
Notation "P ? a" := (tstC P a) (at level 48).
Notation "P1 ; P2" := (seqC P1 P2) (at level 49, left associativity).
Notation "P1 'U' P2" := (choC P1 P2) (at level 51, left associativity).
Notation "P **" := (loopC P) (at level 47, left associativity).

Locate "**".
Check x :=' 4 :: nil.
Check evtC (x :=' 4 :: nil).
Check { x :=' 4 | c1 ! 5}.
Check @ { x :=' 4 | c1 ! 5 }.
Check idle.
Check x '> 0 ? {c!4}.

(* ========================================= Syntax of CDL Formula ===============================================*)

(* ================== CCSL ======================== *)
(* clock relation *)
(***
  Currently, we model clocks as `strings', becuase now we don't need to give its semantics.
  It won't work anymore if we consider its semantics later.
***)

Inductive CRel :=
  crSubClC : string -> string -> CRel |
  crExclC : string -> string -> CRel |
  crPrecC : string -> string -> CRel |
  crCausC : string -> string -> CRel
.
Check CRel.

Notation "c1 'sub' c2" := (crSubClC c1 c2) (at level 52).
Notation "c1 # c2" := (crExclC c1 c2) (at level 52).
Notation "c1 << c2" := (crPrecC c1 c2) (at level 52).
Notation "c1 <<= c2" := (crCausC c1 c2) (at level 52).

Check c1 << c2.
Check c1 # c2.
Check c1 sub c2.

(* ================== CDL Formula ======================== *)
(* Clock relation in formula *)
Inductive rel :=
  rRelC : CRel -> rel |
  rConjC : list CRel -> rel
.
Print rel.

Coercion rRelC : CRel >-> rel.
Check c1 << c2.

Notation "/\{ c1 , .. , cn }" := (rConjC (cons c1 .. (cons cn nil) ..)).
Check /\{ c1 << c2 , c2 sub c3 , c1 <<= c3}.

(* Arith Expression `E' *)
(*DEL
(* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
Definition CntClk := string -> string.

(* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
Definition StClk := string -> string.
DEL*)

Inductive E_exp :=
  EvarC : string -> E_exp |
  ECntClkC : string -> E_exp | (* define a map that maps each clock/signal to a variable that records the number it has ticked in history. *)
  EStClkC : string -> E_exp | (* define a map that maps each clock/signal to a variable that records the current state of this clock. *)
  EnumC : nat -> E_exp |
  EplusC : E_exp -> E_exp -> E_exp |
  (* unecessary expression *)
  EmulC : E_exp -> E_exp -> E_exp |
  EminusC : E_exp -> E_exp -> E_exp |
  EdivC : E_exp -> E_exp -> E_exp
.
Print E_exp.

Coercion EvarC : string >-> E_exp.
Notation "n( c )" := (ECntClkC c) (at level 52). (* the only DIFFERENCE between e_exp and E_exp *)
Notation "s( c )" := (EStClkC c) (at level 52).
Coercion EnumC : nat >-> E_exp.
Notation "e1 +' e2" := (EplusC e1 e2) (at level 55, right associativity).
Notation "e1 *' e2" := (EmulC e1 e2) (at level 53, right associativity).
Notation "e1 -' e2" := (EminusC e1 e2) (at level 55, right associativity).
Notation "e1 /' e2" := (EdivC e1 e2) (at level 53, right associativity).

Check 5 +' 3.
Check 5 '+ 3.
Check 5 *' (3 +' 5).
Check n(c) *' 4.

(* CDL Formula *)
Inductive CDL_exp :=
  cdl_trueC : CDL_exp |
  cdl_ltC : E_exp -> E_exp -> CDL_exp |
  cdl_box1C : SEP_exp -> rel -> CDL_exp |
  cdl_box2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_negC : CDL_exp -> CDL_exp |
  cdl_andC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_forallC : string -> CDL_exp -> CDL_exp |
  (* unnecessary expressions *)
  cdl_falseC : CDL_exp |
  cdl_lteC : E_exp -> E_exp -> CDL_exp |
  cdl_gtC : E_exp -> E_exp -> CDL_exp |
  cdl_gteC : E_exp -> E_exp -> CDL_exp |
  cdl_eqC : E_exp -> E_exp -> CDL_exp |
  cdl_dia1C : SEP_exp -> rel -> CDL_exp |
  cdl_dia2C : SEP_exp -> CDL_exp -> CDL_exp |
  cdl_orC : CDL_exp -> CDL_exp -> CDL_exp |
  cdl_impC : CDL_exp -> CDL_exp -> CDL_exp
.

Notation "'tt''" := cdl_trueC (at level 65).
Notation "e1 <' e2" := (cdl_ltC e1 e2) (at level 61).
Notation "[ p ]' r" := (cdl_box1C p r) (at level 63).
Notation "[ p ] e" := (cdl_box2C p e) (at level 63).
Notation "~' e" := (cdl_negC e) (at level 67).
Notation "e1 /\' e2" := (cdl_andC e1 e2) (at level 69, right associativity).
Notation "'all' x , e" := (cdl_forallC x e) (at level 68).
(* unnecessary expressions *)
Notation "'ff''" := cdl_falseC (at level 65).
Notation "e1 <=' e2" := (cdl_lteC e1 e2) (at level 61).
Notation "e1 >' e2" := (cdl_gtC e1 e2) (at level 61).
Notation "e1 >=' e2" := (cdl_gteC e1 e2) (at level 61).
Notation "e1 =' e2" := (cdl_eqC e1 e2) (at level 61).
Notation "< p >' r" := (cdl_dia1C p r) (at level 63).
Notation "< p > e" := (cdl_dia2C p e) (at level 63).
Notation "e1 \/' e2" := (cdl_orC e1 e2) (at level 71, right associativity).
Notation "e1 ->' e2" := (cdl_impC e1 e2) (at level 72, right associativity).

Check tt'.
Check ff'.
Check (5 -' 3) <' 2.
Check ([skip]' c1 << c2) /\' 2 >' 5 /\' tt'.
Check [@ {x :=' 4 | c1 ! 5} ; (x '> 0) ? {c2!4} ; @ idle; skip] n(c) >' 0.
Check [(@ {x :=' 4 | c1 ! 5} ; (x '> 0) ? {c2!4} ; @ idle; skip)**]' c1<<c2.
Check all x , 4 =' 5.

(* ===================================================== CDL Calculus ======================================*)
(*************************** Auxiliary Functions ***************************)
(*check if a dynamic formula is a pure FOL formula *)

Fixpoint CheckPureFOL (e : CDL_exp) : Prop :=
  match e with
  | cdl_trueC => True
  | cdl_ltC e1 e2 => True
  | cdl_box1C p r => False
  | cdl_box2C p e' => False
  | cdl_negC e' => CheckPureFOL e'
  | cdl_andC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  | cdl_forallC x e' => (CheckPureFOL e')
  | cdl_falseC => True
  | cdl_lteC e1 e2 => True
  | cdl_gtC e1 e2 => True
  | cdl_gteC e1 e2 => True
  | cdl_eqC e1 e2 => True
  | cdl_dia1C p r => False
  | cdl_dia2C p e' => False
  | cdl_orC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  | cdl_impC e1 e2 => (CheckPureFOL e1) /\ (CheckPureFOL e2)
  end.

(* a structure of (true, false, `undefined') *)
Inductive Bool :=
  bBoolC : Prop -> Bool |
  bUndefC : Bool
.

Notation "[ b ]" := (bBoolC b) (at level 74).
Notation "_|_" := bUndefC (at level 74).

(* evaluate a pure FOL formula in CDL formula *)

(*************************** Rules for FOL **********************************)
(* To be simple, we firstly define a sequent as a triple (\Gamma, formula, \Delta), where \Gamma and \Delta are the context of
the formula that we are going to transform. *)

Definition Gamma := list CDL_exp.
Definition Delta := list CDL_exp.

(***DEL Definition SequentL : Gamma -> CDL_exp -> Delta -> Prop.*)

(* we arrange a place special for the dynamic formula we want to verify in the sequent, other formulas in Gamma
and Delta are pure FOL formulas.

We define two types of sequent: sequentL and sequentR, where L and R indicate the verifiying formula is on the left
or right side of the sequent.
*)

Inductive place :=
  pexpC : CDL_exp -> place |
  pnothingC : place
.

(*
Notation "/ e /" := (pexpC e) (at level 74).
Notation "/ /" := pnothingC (at level 74).
Check / x <=' y /.
*)

Reserved Notation "T , p1 ==> p2 , D" (at level 75).
(*Reserved Notation "T ==> p , D" (at level 75).*)

Locate "==>".

(* substitution /single variable*)
Fixpoint E_exp_subs (e : E_exp) (x' : string) (x : string) : E_exp :=
  match e with
  | EvarC v => if (string_dec v x) then EvarC x' else EvarC v
  | ECntClkC c => ECntClkC c (* do not consider replacing a clock-related variable *)
  | EStClkC c => EStClkC c
  | EnumC n => EnumC n
  | EplusC e1 e2 => EplusC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | EmulC e1 e2 => EmulC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | EminusC e1 e2 => EminusC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | EdivC e1 e2 => EdivC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  end
.

Compute E_exp_subs (x +' y) y x.
Compute E_exp_subs (x *' z) y c.
Compute E_exp_subs (n(c) *' z) y z.

Fixpoint e_exp_subs (e : e_exp) (x' : string) (x : string) : e_exp :=
  match e with
  | enumC n => enumC n
  | evarC s => if (string_dec s x) then evarC x' else evarC s
  | eplusC e1 e2 => eplusC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | eminusC e1 e2 => eminusC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | emulC e1 e2 => emulC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | edivC e1 e2 => edivC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  end
.

Fixpoint P_exp_subs (P : P_exp) (x' : string) (x : string) : P_exp :=
  match P with
  | PtrueC => PtrueC
  | PlteC e1 e2 => PlteC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PnegC P' => PnegC (P_exp_subs P' x' x)
  | PandC P1 P2 => PandC (P_exp_subs P1 x' x) (P_exp_subs P2 x' x)
  | PfalseC => PfalseC
  | PltC e1 e2 => PltC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PgtC e1 e2 => PgtC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PgteC e1 e2 => PgteC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PeqC e1 e2 => PeqC (e_exp_subs e1 x' x) (e_exp_subs e2 x' x)
  | PorC P1 P2 => PorC (P_exp_subs P1 x' x) (P_exp_subs P2 x' x)
  | PimpC P1 P2 => PimpC (P_exp_subs P1 x' x) (P_exp_subs P2 x' x)
  end
.

Fixpoint cdl_subs (e : CDL_exp) (x' : string) (x : string) : CDL_exp := (* e[x'/x] *)
  match e with
  | cdl_trueC => cdl_trueC
  | cdl_ltC e1 e2 => cdl_ltC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_box1C p r => cdl_box1C (SEP_subs p x' x) r (* do not consider replacing a clock-related variable *)
  | cdl_box2C p e' => cdl_box2C (SEP_subs p x' x) (cdl_subs e' x' x)
  | cdl_negC e' => cdl_negC (cdl_subs e' x' x)
  | cdl_andC e1 e2 => cdl_andC (cdl_subs e1 x' x) (cdl_subs e2 x' x)
  | cdl_forallC x1 e' => if (string_dec x1 x) then cdl_forallC x1 e' else (cdl_subs e' x' x)
  | cdl_falseC => cdl_falseC
  | cdl_lteC e1 e2 => cdl_lteC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_gtC e1 e2 => cdl_gtC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_gteC e1 e2 => cdl_gteC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_eqC e1 e2 => cdl_eqC (E_exp_subs e1 x' x) (E_exp_subs e2 x' x)
  | cdl_dia1C p r => cdl_dia1C (SEP_subs p x' x) r (* do not consider replacing a clock-related variable *)
  | cdl_dia2C p e' => cdl_dia2C (SEP_subs p x' x) (cdl_subs e' x' x)
  | cdl_orC e1 e2 => cdl_orC (cdl_subs e1 x' x) (cdl_subs e2 x' x)
  | cdl_impC e1 e2 => cdl_impC (cdl_subs e1 x' x) (cdl_subs e2 x' x)
  end.

(*&&&&&&&&&&&&&&&&&&&&&&&&&&&& testing &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&*)
(*** as a test, we firstly implement a simple rule here, to check if everything in my mind would work well,
we first realize the rule:
    T[x'/x],x = e[x'/x] => E, D[x'/x]
    ---------------------------------
    T => [x := e] E, D

It is equavalent to realize the rule:
    forall x'. (x' not free in T, e, D) -> (T[x'/x],x = e[x'/x] => E, D[x'/x]) -> (T => [x := e] E, D)
***)

Inductive validSeq : sequent -> Type :=
  tst : forall (T : Gamma) (p : CDL_exp) (D : Delta), (CheckPureFOL p) -> validSeq ( T ==> p , D ).


Require Import Coq.Lists.List.
Require Import DschingisKhan.Prelude.PreludeInit.
Require Import DschingisKhan.Prelude.PreludeMath.
Require Import DschingisKhan.Prelude.PreludeUtil.
Require Import DschingisKhan.Prelude.PreludeClassic.
Require Import DschingisKhan.Math.BasicPosetTheory.
Require Import DschingisKhan.Math.BooleanAlgebra.
Require Import DschingisKhan.Logic.PropositionalLogic.

Module ClassicalMetaTheoryOnPropositonalLogic.

  Import ListNotations ExcludedMiddle BooleanAlgebra CountableBooleanAlgebra SyntaxOfPL SemanticsOfPL InferenceRulesOfPL LindenbaumBooleanAlgebraOfPL ConstructiveMetaTheoryOnPropositonalLogic.

  Lemma ByAssumption_preserves (Gamma : ensemble formula) (C : formula)
    (ELEM : C \in Gamma)
    : Gamma ⊧ C.
  Proof with eauto with *.
    eapply extend_entails with (Gamma := singleton C)...
    ii. eapply env_satisfies...
  Qed.

  Lemma ContradictionI_preserves (Gamma : ensemble formula) (A : formula)
    (ENTAILS1 : Gamma ⊧ A)
    (ENTAILS2 : Gamma ⊧ NegationF A)
    : Gamma ⊧ ContradictionF.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1. pose proof (ENTAILS2 env env_satisfies) as claim2.
    inversion claim1; subst. inversion claim2; subst. econstructor...
  Qed.

  Lemma ContradictionE_preserves (Gamma : ensemble formula) (A : formula)
    (ENTAILS1 : Gamma ⊧ ContradictionF)
    : Gamma ⊧ A.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1.
    inversion claim1; subst. econstructor...
  Qed.

  Lemma NegationI_preserves (Gamma : ensemble formula) (A : formula)
    (ENTAILS1 : insert A Gamma ⊧ ContradictionF)
    : Gamma ⊧ NegationF A.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. econstructor. simpl. intros EVAL_TO_TRUE.
    assert (claim1 : forall b : formula, member b (insert A Gamma) -> env `satisfies` b).
    { intros b. rewrite in_insert_iff. intros [A_eq_b | b_in_Gamma]...
      subst b. econstructor...
    }
    pose proof (ENTAILS1 env claim1) as claim2.
    inversion claim2; subst...
  Qed.

  Lemma NegationE_preserves (Gamma : ensemble formula) (A : formula)
    (ENTAILS1 : insert (NegationF A) Gamma ⊧ ContradictionF)
    : Gamma ⊧ A.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. econstructor. eapply NNPP. intros EVAL_TO_FALSE.
    assert (claim1 : forall b : formula, member b (insert (NegationF A) Gamma) -> env `satisfies` b).
    { intros b. rewrite in_insert_iff. intros [NegationF_A_eq_b | b_in_Gamma]...
      subst b. econstructor...
    }
    pose proof (ENTAILS1 env claim1) as claim2.
    inversion claim2; subst...
  Qed.

  Lemma ConjunctionI_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : Gamma ⊧ A)
    (ENTAILS2 : Gamma ⊧ B)
    : Gamma ⊧ ConjunctionF A B.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1. pose proof (ENTAILS2 env env_satisfies) as claim2.
    inversion claim1; subst. inversion claim2; subst. econstructor...
  Qed.

  Lemma ConjunctionE1_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : Gamma ⊧ ConjunctionF A B)
    : Gamma ⊧ A.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1.
    inversion claim1; subst. econstructor...
  Qed.

  Lemma ConjunctionE2_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : Gamma ⊧ ConjunctionF A B)
    : Gamma ⊧ B.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1.
    inversion claim1; subst. econstructor...
  Qed.

  Lemma DisjunctionI1_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : Gamma ⊧ A)
    : Gamma ⊧ DisjunctionF A B.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1.
    inversion claim1; subst. econstructor...
  Qed.

  Lemma DisjunctionI2_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : Gamma ⊧ B)
    : Gamma ⊧ DisjunctionF A B.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1.
    inversion claim1; subst. econstructor...
  Qed.

  Lemma DisjunctionE_preserves (Gamma : ensemble formula) (A : formula) (B : formula) (C : formula)
    (ENTAILS1 : Gamma ⊧ DisjunctionF A B)
    (ENTAILS2 : insert A Gamma ⊧ C)
    (ENTAILS3 : insert B Gamma ⊧ C)
    : Gamma ⊧ C.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. econstructor.
    pose proof (ENTAILS1 env env_satisfies) as claim1.
    inversion claim1; subst.
    destruct EVAL_TO_TRUE as [EVAL_TO_TRUE | EVAL_TO_TRUE].
    - assert (claim2 : forall b : formula, member b (insert A Gamma) -> env `satisfies` b).
      { intros b. rewrite in_insert_iff. intros [A_eq_b | b_in_Gamma]...
        subst b. econstructor...
      }
      pose proof (ENTAILS2 env claim2) as claim3.
      inversion claim3; subst...
    - assert (claim2 : forall b : formula, member b (insert B Gamma) -> env `satisfies` b).
      { intros b. rewrite in_insert_iff. intros [B_eq_b | b_in_Gamma]...
        subst b. econstructor...
      }
      pose proof (ENTAILS3 env claim2) as claim3.
      inversion claim3; subst...
  Qed.

  Lemma ImplicationI_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : insert A Gamma ⊧ B)
    : Gamma ⊧ ImplicationF A B.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. econstructor. simpl. intros EVAL_TO_TRUE.
    assert (claim1 : forall b : formula, member b (insert A Gamma) -> env `satisfies` b).
    { intros b. rewrite in_insert_iff. intros [A_eq_b | b_in_Gamma]...
      subst b. econstructor...
    }
    pose proof (ENTAILS1 env claim1) as claim2.
    inversion claim2; subst...
  Qed.

  Lemma ImplicationE_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : Gamma ⊧ ImplicationF A B)
    (ENTAILS2 : Gamma ⊧ A)
    : Gamma ⊧ B.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1. inversion claim1; subst.
    econstructor. simpl in EVAL_TO_TRUE. eapply EVAL_TO_TRUE.
    pose proof (ENTAILS2 env env_satisfies) as claim2. inversion claim2; subst...
  Qed.

  Lemma BiconditionalI_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : insert A Gamma ⊧ B)
    (ENTAILS2 : insert B Gamma ⊧ A)
    : Gamma ⊧ BiconditionalF A B.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. econstructor. simpl. split; intros EVAL_TO_TRUE.
    - assert (claim1 : forall b : formula, member b (insert A Gamma) -> env `satisfies` b).
      { intros b. rewrite in_insert_iff. intros [A_eq_b | b_in_Gamma]...
        subst b. econstructor...
      }
      pose proof (ENTAILS1 env claim1) as claim2.
      inversion claim2; subst...
    - assert (claim1 : forall b : formula, member b (insert B Gamma) -> env `satisfies` b).
      { intros b. rewrite in_insert_iff. intros [B_eq_b | b_in_Gamma]...
        subst b. econstructor...
      }
      pose proof (ENTAILS2 env claim1) as claim2.
      inversion claim2; subst...
  Qed.

  Lemma BiconditionalE1_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : Gamma ⊧ BiconditionalF A B)
    (ENTAILS2 : Gamma ⊧ A)
    : Gamma ⊧ B.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1. inversion claim1; subst.
    econstructor. simpl in EVAL_TO_TRUE. eapply EVAL_TO_TRUE.
    pose proof (ENTAILS2 env env_satisfies) as claim2. inversion claim2; subst...
  Qed.

  Lemma BiconditionalE2_preserves (Gamma : ensemble formula) (A : formula) (B : formula)
    (ENTAILS1 : Gamma ⊧ BiconditionalF A B)
    (ENTAILS2 : Gamma ⊧ B)
    : Gamma ⊧ A.
  Proof with (simpl in *; tauto) || eauto with *.
    ii. pose proof (ENTAILS1 env env_satisfies) as claim1. inversion claim1; subst.
    econstructor. simpl in EVAL_TO_TRUE. eapply EVAL_TO_TRUE.
    pose proof (ENTAILS2 env env_satisfies) as claim2. inversion claim2; subst...
  Qed.

  Theorem the_propositional_soundness_theorem (X : ensemble formula) (b : formula)
    (INFERS : X ⊢ b)
    : X ⊧ b.
  Proof with eauto.
    induction INFERS.
    - eapply ByAssumption_preserves with (C := C)...
    - eapply ContradictionI_preserves with (A := A)...
    - eapply ContradictionE_preserves with (A := A)...
    - eapply NegationI_preserves with (A := A)...
    - eapply NegationE_preserves with (A := A)...
    - eapply ConjunctionI_preserves with (A := A) (B := B)...
    - eapply ConjunctionE1_preserves with (A := A) (B := B)...
    - eapply ConjunctionE2_preserves with (A := A) (B := B)...
    - eapply DisjunctionI1_preserves with (A := A) (B := B)...
    - eapply DisjunctionI2_preserves with (A := A) (B := B)...
    - eapply DisjunctionE_preserves with (A := A) (B := B) (C := C)...
    - eapply ImplicationI_preserves with (A := A) (B := B)...
    - eapply ImplicationE_preserves with (A := A) (B := B)...
    - eapply BiconditionalI_preserves with (A := A) (B := B)...
    - eapply BiconditionalE1_preserves with (A := A) (B := B)...
    - eapply BiconditionalE2_preserves with (A := A) (B := B)...
  Qed.

  Lemma hasModelIfConsistent (X : ensemble formula)
    (CONSISTENT : ~ X ⊢ ContradictionF)
    : isSubsetOf X (MaximalConsistentSet X) /\ isStructure (MaximalConsistentSet X).
  Proof with eauto with *. (* Infinitely grateful for Taeseung's advice! *)
    revert X CONSISTENT.
    pose proof (lemma1 := @isSubsetOf_singleton_if formula).
    assert (lemma2 : forall X : ensemble formula, forall x : formula, isSubsetOf X (insert x X)).
    { ii; ensemble_rewrite. }
    pose proof (lemma3 := @isSubsetOf_empty_if formula).
    assert (lemma4 : forall X : ensemble formula, forall x : formula, member x (insert x X)).
    { ii; ensemble_rewrite. }
    ii. set (X_dagger := MaximalConsistentSet X).
    pose proof (theorem_of_1_3_10 X) as [? ? ? ? ?].
    fold X_dagger in SUBSET, EQUICONSISTENT, CLOSED_infers, META_DN, IMPLICATION_FAITHFUL.
    pose proof (theorem_of_1_2_14 (Th X) (lemma1_of_1_3_8 X)) as [SUBSET' IS_FILTER' COMPLETE' EQUICONSISTENT'].
    fold (MaximalConsistentSet X) in SUBSET', IS_FILTER', COMPLETE', EQUICONSISTENT'.
    fold X_dagger in SUBSET', IS_FILTER', COMPLETE', EQUICONSISTENT'.
    pose proof (claim1 := Th_isSubsetOf_cl X).
    pose proof (claim2 := cl_isSubsetOf_Th X).
    assert (claim3 : equiconsistent (cl X) X_dagger).
    { split; intros INCONSISTENT.
      - eapply inconsistent_compatWith_isSubsetOf with (X := Th X)...
        rewrite <- cl_eq_Th...
      - eapply inconsistent_compatWith_isSubsetOf with (X := Th X)...
        eapply EQUICONSISTENT...
    }
    assert (claim4 : ~ inconsistent X_dagger).
    { intros INCONSISTENT. contradiction CONSISTENT.
      eapply inconsistent_cl_iff, claim3...
    }
    assert (claim5 : ~ inconsistent (cl X_dagger)).
    { intros INCONSISTENT. contradiction claim4.
      eapply inconsistent_compatWith_isSubsetOf with (X := cl X_dagger)...
      eapply fact5_of_1_2_8...
    }
    assert (
      forall i : propLetter,
      AtomF i \in X_dagger <-> evalFormula (preimage AtomF X_dagger) (AtomF i)
    ) as caseAtomF.
    { ii. change (AtomF i \in X_dagger <-> i \in preimage AtomF X_dagger).
      rewrite in_preimage_iff. split...
      intros [p [? ?]]; subst p...
    }
    assert (
      ContradictionF \in X_dagger <-> evalFormula (preimage AtomF X_dagger) ContradictionF
    ) as caseContradictionF.
    { simpl. rewrite CLOSED_infers, <- inconsistent_cl_iff. tauto. }
    assert (
      forall p1 : formula,
      forall IH1 : p1 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) p1,
      NegationF p1 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) (NegationF p1)
    ) as caseNegationF.
    { ii. simpl. rewrite <- IH1, CLOSED_infers. split.
      - intros INFERS H_in.
        contradiction claim5.
        eapply inconsistent_cl_iff. eapply ContradictionI with (A := p1)...
        eapply CLOSED_infers...
      - intros H_not_in.
        eapply CLOSED_infers, META_DN. unnw. intros H_in.
        eapply CLOSED_infers. eapply ContradictionI with (A := NegationF p1).
        + enough (claim6 : MaximalConsistentSet X ⊢ ImplicationF p1 ContradictionF).
          { eapply NegationI. eapply ImplicationE with (A := p1).
            - eapply extend_infers...
            - eapply ByAssumption...
          }
          eapply CLOSED_infers, IMPLICATION_FAITHFUL. tauto.
        + eapply ByAssumption...
    }
    assert (
      forall p1 : formula,
      forall p2 : formula,
      forall IH1 : p1 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) p1,
      forall IH2 : p2 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) p2,
      ConjunctionF p1 p2 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) (ConjunctionF p1 p2)
    ) as caseConjunctionF.
    { ii. simpl. rewrite <- IH1, <- IH2. split.
      - intros H_in. split.
        + eapply CLOSED_infers, ConjunctionE1, CLOSED_infers...
        + eapply CLOSED_infers, ConjunctionE2, CLOSED_infers...
      - intros [H_in1 H_in2].
        eapply CLOSED_infers, ConjunctionI; eapply CLOSED_infers...
    }
    assert (
      forall p1 : formula,
      forall p2 : formula,
      forall IH1 : p1 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) p1,
      forall IH2 : p2 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) p2,
      DisjunctionF p1 p2 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) (DisjunctionF p1 p2)
    ) as caseDisjunctionF.
    { ii. simpl. rewrite <- IH1, <- IH2. split.
      - intros H_in. pose proof (classic (X_dagger ⊢ p1)) as [H_yes | H_no].
        + left. eapply CLOSED_infers...
        + right. eapply CLOSED_infers.
          eapply ImplicationE with (A := NegationF p1).
          { eapply DisjunctionE with (A := p1) (B := p2) (C := ImplicationF (NegationF p1) p2).
            - eapply CLOSED_infers...
            - eapply ImplicationI, ContradictionE. eapply ContradictionI with (A := p1).
              + eapply ByAssumption. right; left...
              + eapply ByAssumption. left...
            - eapply ImplicationI, ByAssumption. right; left...
          }
          { eapply CLOSED_infers, caseNegationF...
            simpl. rewrite <- IH1. intros H_false.
            apply CLOSED_infers in H_false...
          }
      - intros [H_in | H_in].
        + eapply CLOSED_infers, DisjunctionI1, CLOSED_infers...
        + eapply CLOSED_infers, DisjunctionI2, CLOSED_infers...
    }
    assert (
      forall p1 : formula,
      forall p2 : formula,
      forall IH1 : p1 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) p1,
      forall IH2 : p2 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) p2,
      ImplicationF p1 p2 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) (ImplicationF p1 p2)
    ) as caseImplicationF.
    { ii. rewrite IMPLICATION_FAITHFUL. simpl. unnw. tauto. }
    assert (
      forall p1 : formula,
      forall p2 : formula,
      forall IH1 : p1 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) p1,
      forall IH2 : p2 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) p2,
      BiconditionalF p1 p2 \in X_dagger <-> evalFormula (preimage AtomF X_dagger) (BiconditionalF p1 p2)
    ) as caseBiconditionalF.
    { ii. simpl. transitivity (ImplicationF p1 p2 \in X_dagger /\ ImplicationF p2 p1 \in X_dagger).
      { split.
        - intros H_in. split.
          { eapply CLOSED_infers, ImplicationI. eapply BiconditionalE1 with (A := p1) (B := p2).
            - eapply extend_infers with (Gamma := X_dagger)...
              eapply CLOSED_infers...
            - eapply ByAssumption. left...
          }
          { eapply CLOSED_infers, ImplicationI. eapply BiconditionalE2 with (A := p1) (B := p2).
            - eapply extend_infers with (Gamma := X_dagger)...
              eapply CLOSED_infers...
            - eapply ByAssumption. left...
          }
        - intros [H_in1 H_in2].
          eapply CLOSED_infers, BiconditionalI.
          { eapply ImplicationE with (A := p1).
            - eapply extend_infers with (Gamma := X_dagger)...
              eapply CLOSED_infers...
            - eapply ByAssumption. left...
          }
          { eapply ImplicationE with (A := p2).
            - eapply extend_infers with (Gamma := X_dagger)...
              eapply CLOSED_infers...
            - eapply ByAssumption. left...
          }
      }
      { split.
        - intros [H_in1 H_in2]. eapply caseImplicationF in H_in1, H_in2...
        - intros [H_in1 H_in2]. eapply caseImplicationF in H_in1, H_in2...
      }
    }
    split.
    { transitivity (Th X)... ii. econstructor. eapply ByAssumption... }
    { unfold isStructure. induction A... }
  Qed.

  Theorem the_propositional_completeness_theorem (Gamma : ensemble formula) (C: formula)
    (ENTAILS : Gamma ⊧ C)
    : Gamma ⊢ C.
  Proof with eauto with *.
    eapply NNPP. intros it_is_false_that_Gamma_infers_C.
    set (X := insert (NegationF C) Gamma).
    assert (CONSISTENT : X ⊬ ContradictionF).
    { intros INCONSISTENT. contradiction it_is_false_that_Gamma_infers_C. eapply NegationE... }
    pose proof (theorem_of_1_2_14 (Th X) (lemma1_of_1_3_8 X)) as [SUBSET' IS_FILTER' COMPLETE' EQUICONSISTENT'].
    fold (MaximalConsistentSet X) in SUBSET', IS_FILTER', COMPLETE', EQUICONSISTENT'.
    pose proof (hasModelIfConsistent X CONSISTENT) as [INCL IS_STRUCTURE].
    unfold isStructure in IS_STRUCTURE.
    pose proof (theorem_of_1_3_10 Gamma) as [? ? ? ? ?]; unnw.
    contradiction it_is_false_that_Gamma_infers_C.
    eapply completeness_theorem_prototype with (env := preimage AtomF (MaximalConsistentSet X)); trivial.
    - unfold equiconsistent in *.
      transitivity (inconsistent (MaximalConsistentSet X))...
      split; intros [botBA [botBA_in botBA_eq_falseBA]].
      + exists (botBA). split... eapply IS_STRUCTURE...
      + exists (botBA). split... eapply IS_STRUCTURE...
    - transitivity (MaximalConsistentSet X)...
      ii. eapply IS_STRUCTURE...
    - eapply isFilter_compatWith_eqProp...
  Qed.

  Corollary the_propositional_compactness_theorem (Gamma : ensemble formula) (C : formula)
    : Gamma ⊧ C <-> << FINITE_ENTAILS : exists xs : list formula, exists X : ensemble formula, isFiniteSubsetOf xs Gamma /\ isListRepOf xs X /\ X ⊧ C >>.
  Proof with eauto.
    unnw. split.
    - intros ENTAILS.
      apply the_propositional_completeness_theorem in ENTAILS.
      apply inference_is_finite in ENTAILS. des. exists (xs), (X').
      split... split... eapply the_propositional_soundness_theorem...
    - des. eapply extend_entails... now firstorder.
  Qed.

End ClassicalMetaTheoryOnPropositonalLogic.


(* 2011_01_22 *)

(* 依存積 *)
(* Prop型 *)
Inductive my_ex (A : Type) (P : A -> Prop) : Prop :=
| my_ex_intro : forall x : A, P x -> my_ex A P.
Notation "'exists' x : A, P" := (my_ex (fun A (x : A) => P x)) (at level 190).

(* 関数型 *)
Inductive my_sig (A : Type) (P : A -> Prop) : Type :=
| my_exist : forall x : A, P x -> my_sig A P.
Notation "{ x : A, P }" := (my_sig (fun A (x : A) => P x)) (at level 190).

(* 依存和 *)
(* Prop型 （普通の or） *)
Inductive my_or (A B : Prop) : Prop :=
| my_or_introl : A -> my_or A B
| my_or_intror : B -> my_or A B.
Notation " A \/ B " := (my_or A B).

(* 関数型 *)
Inductive my_sumbool (A B : Prop) : Set :=
| my_left  : A -> my_sumbool A B
| my_right : B -> my_sumbool A B.
Notation "{ A } + { B }" := (my_sumbool A B).

(*
   sumboolで left と rightタクティクスが使える理由：

   タクティクス left は、constructor 1
   タクティクス right は、constructor 2
   の略記で、それぞれ1番めと2番めのコンストラクタをapplyする。
   my_right, my_left の順番に書くと
   タクティクス left が、apply my_right になってしまう。
*)

(********)
(* 応用 *)
(********)

(* exists n, 0 <= n : Prop
   と同じものを定義する。
   ただし、my_ex を使ったわけではない。
   *)
Inductive my_le_zero : nat -> Prop :=
| my_le_0 : my_le_zero 0
| my_le_S : forall n : nat,
  my_le_zero n -> my_le_zero (S n).

Goal my_le_zero 1.                          (* 1 *)
Proof.
  apply my_le_S.
  apply my_le_0.
Qed.

(* zerop :
   {n = 0} + {0 < n} と同じものを定義する
   *)
Require Import Arith.                       (* gt_le_S など *)
Definition my_zerop n : my_sumbool (n = 0) (0 < n).
destruct n.
apply my_left; apply refl_equal.
apply my_right; change (1 <= S n);
  apply gt_le_S; change (0 < S n);
    apply lt_O_Sn.
Defined.                                    (* Defined *)

Eval compute in (match my_zerop 1 with
                   | my_left _ => 0
                   | my_right _ => 100 end). (* 100 *)

(* END *)


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Basic_Cons.CCC.
From Categories Require Import Coq_Cats.Coq_Cat.

(*
**********************************************************
***************                          *****************
***************     Prop Category        *****************
***************                          *****************
**********************************************************
*)

(* The category of Types in Coq's "Prop" universe (Coq's Proposits) *)

Program Definition Prop_Cat : Category := Coq_Cat Prop.

Local Hint Extern 1 => contradiction.

Program Instance False_init : (𝟘_ Prop_Cat)%object := {|terminal := False|}.

Local Hint Extern 1 => match goal with
                        |- ?A = ?B :> True => destruct A; destruct B
                      end.

Program Instance True_term : (𝟙_ Prop_Cat)%object := {terminal := True}.

Local Hint Extern 1 => match goal with
                        |- ?A = ?B :> _ ∧ _ => destruct A; destruct B
                      end.

Local Hint Extern 1 => tauto.

Section Prod.
  Context (P Q : Prop).

  Local Notation "P × Q" := (Product Prop_Cat P Q) : object_scope.

  Program Definition Conj_Product : (P × Q)%object := {|product := (P ∧ Q)|}.

  Local Obligation Tactic := idtac.

  Next Obligation. (* Prod_morph_unique *)
  Proof.
    intros p' r1 r2 f g H1 H2 H3 H4.
    rewrite <- H3 in H1.
    rewrite <- H4 in H2.
    clear H3 H4.
    extensionality x.
    apply (fun p => equal_f p x) in H1; apply (fun p => equal_f p x) in H2.
    cbn in H1, H2.
  destruct (f x); destruct (g x); cbn in *; subst; trivial.
  Qed.

End Prod.

Program Instance Prop_Cat_Has_Products : Has_Products Prop_Cat := Conj_Product.

Local Hint Extern 1 => match goal with H : _ ∧ _ |- _ => destruct H end.

Section Exp.
  Context (P Q : Prop_Cat).

  Program Definition implication_exp : (P ⇑ Q)%object
    :=
      {|
        exponential := (P -> Q)
      |}.

  Local Obligation Tactic := idtac.

  Next Obligation. (* Exp_morph_unique *)
  Proof.
    intros z f u u' H1 H2.
    rewrite H1 in H2; clear H1.
    extensionality a; extensionality x.
    apply (fun p => equal_f p (conj a x)) in H2.
    assumption.
  Qed.

End Exp.

Program Instance Prop_Cat_Has_Exponentials : Has_Exponentials Prop_Cat :=
  implication_exp.

Program Instance Prop_Cat_CCC : CCC Prop_Cat.

Local Hint Extern 1 => match goal with H : _ ∨ _ |- _ => destruct H end.

Section Sum.
  Context (P Q : Prop).

  Local Notation "P + Q" := (Sum Prop_Cat P Q) : object_scope.

  Program Definition Disj_Sum  : (P + Q)%object := {|product := (P ∨ Q)|}.

  Local Obligation Tactic := idtac.

  Next Obligation. (* Sum_morph_unique *)
  Proof.
    intros p' r1 r2 f g H1 H2 H3 H4.
    rewrite <- H3 in H1.
    rewrite <- H4 in H2.
    clear H3 H4.
    extensionality x.
    destruct x as [x1|x2].
    + apply (fun p => equal_f p x1) in H1; auto.
    + apply (fun p => equal_f p x2) in H2; auto.
  Qed.

End Sum.

Program Instance Prop_Cat_Has_Sums : Has_Sums Prop_Cat := Disj_Sum.


Require Import HoTT.
Require Export structures basics.

Open Scope path_scope.

Import Magma2_pr.

Section Product.

Definition law_prod : forall {G G'}, law G -> law G' -> law (G*G')
  := fun G G' f g x y => match x,y with
    | (a,b) , (a',b') => (f a a', g b b')
    end.

Canonical Structure mag_prod : forall (G G' : magma), magma
 := fun G G' => BuildMagma (G*G') (BuildClass (law_prod gop gop)).

Infix "*" := mag_prod.

Instance prod_comm : forall {G}, Commutative G ->
forall {H}, Commutative H -> Commutative (G * H).
Proof.
red;intros.
destruct x,y. unfold gop;simpl.
apply ap11;[apply ap|];auto.
Defined.

Instance prod_assoc : forall {G}, Associative G ->
forall {H}, Associative H -> Associative (G * H).
Proof.
red;intros.
destruct x,y,z. unfold gop;simpl.
apply ap11;[apply ap|];auto.
Defined.

Instance prod_is_sg : forall G {Hsg : IsSemigroup G}
 H {Hsg' : IsSemigroup H}, IsSemigroup (G * H).
Proof.
intros.
apply BuildIsSemigroup.
apply prod_assoc. apply Hsg. apply Hsg'.
apply prod_comm. apply Hsg. apply Hsg'.
Defined.

Canonical Structure prod_sg : forall {G H : semigroup}, semigroup
  := fun G H => BuildSemigroup (G*H) (prod_is_sg _ _).

Instance prod_is_monoid : forall {G} {Hsg : IsMonoid G}
 {H} {Hsg' : IsMonoid H}, IsMonoid (G * H).
Proof.
intros. apply BuildIsMonoid. apply _. apply BuildIdentity with (gidV, gidV).
apply left_id_id. red. intros [x x'].
unfold gop;simpl.
apply ap11;[apply ap|];apply gid_id.
Defined.

Canonical Structure prod_monoid : forall {G H : monoid}, monoid
  := fun G H => BuildMonoid (G*H) prod_is_monoid.

Lemma prod_Lcancel_pair : forall {G H : magma} (a : G) (b : H),
Lcancel a -> Lcancel b -> Lcancel (a, b).
Proof.
red;intros.
destruct b0;destruct c.
simpl in X1. apply equiv_path_prod in X1;simpl in X1.
apply path_prod;simpl;[apply X | apply X0];apply X1.
Defined.

Lemma prod_Rcancel_pair : forall {G H : magma} (a : G) (b : H),
Rcancel a -> Rcancel b -> Rcancel (a, b).
Proof.
red;intros.
destruct b0;destruct c.
simpl in X1. apply equiv_path_prod in X1;simpl in X1.
apply path_prod;simpl;[apply X | apply X0];apply X1.
Defined.

Lemma prod_Cancel_pair : forall {G H : magma} (a : G) (b : H),
Cancel a -> Cancel b -> Cancel (a, b).
Proof.
intros;split;
[apply prod_Lcancel_pair | apply prod_Rcancel_pair];
first [apply X | apply X0].
Defined.

Instance prod_is_cmonoid : forall {G} {Hsg : IsCMonoid G}
 {H} {Hsg' : IsCMonoid H}, IsCMonoid (G * H).
Proof.
intros. apply BuildIsCMonoid. apply _.
intros; destruct a;apply prod_Cancel_pair;apply cmonoid_cancel.
Defined.

Canonical Structure prod_cmonoid : forall {G H : Cmonoid}, Cmonoid
 := fun G H => BuildCMonoid (G*H) _.

Definition prod_apart {A B : Type} (f : A -> B) {C D : Type} (g : C -> D)
 : (A*C) -> (B*D) := fun p => let (a,c) := p in (f a, g c).

Instance prod_linverse : forall {G H : monoid},
forall x y : G, Linverse x y ->
forall x' y' : H, Linverse x' y' ->
Linverse (x,x') (y,y').
Proof.
intros;red. unfold gop;simpl.
apply ap11;[apply ap;apply X|apply X0].
Defined.

Instance prod_rinverse : forall {G H : monoid},
forall x y : G, Rinverse x y ->
forall x' y' : H, Rinverse x' y' ->
Rinverse (x,x') (y,y').
Proof.
intros. apply prod_linverse;assumption.
Defined.

Instance prod_inverse : forall {G H : monoid},
forall x y : G, IsInverse x y ->
forall x' y' : H, IsInverse x' y' ->
IsInverse (x,x') (y,y').
Proof.
intros;split;[apply prod_linverse | apply prod_rinverse];
first [apply X | apply X0].
Defined.

Instance prod_is_group : forall {G} {Hsg : IsGroup G}
 {H} {Hsg' : IsGroup H}, IsGroup (G * H).
Proof.
intros. apply easyIsGroup with prod_is_monoid (prod_apart gopp gopp).
intros [a b]. simpl. apply prod_inverse;apply gopp_correct.
Defined.

Canonical Structure prod_group : forall {G H : group}, group
 := fun G H => BuildGroup (G*H) _.

Canonical Structure mag2_prod : forall (G G' : magma2), magma2
 := fun G G' => BuildMagma2 (G*G')
(BuildClass (law_prod radd radd)) (BuildClass (law_prod rmult rmult)).

Infix "*" := mag2_prod.

Instance prod_left_distrib : forall {G} (Hg : Ldistributes G)
 {H} (Hh : Ldistributes H), Ldistributes (G*H).
Proof.
intros;red. intros [a1 a2] [b1 b2] [c1 c2].
unfold rmult;unfold radd;unfold gop;simpl;
apply ap11;[apply ap;apply Hg|apply Hh].
Defined.

Instance prod_right_distrib : forall {G} (Hg : Rdistributes G)
 {H} (Hh : Rdistributes H), Rdistributes (G*H).
Proof.
intros;red. intros [a1 a2] [b1 b2] [c1 c2].
unfold radd;unfold rmult;unfold gop;simpl;
apply ap11;[apply ap;apply Hg|apply Hh].
Defined.

Instance prod_distrib : forall {G} (Hg : Distributes G)
 {H} (Hh : Distributes H), Distributes (G*H).
Proof.
intros;split;[apply prod_left_distrib | apply prod_right_distrib];
first [apply Hg | apply Hh].
Defined.

Instance prod_is_semiring : forall {G} {Hg : IsSemiring G}
{H} {Hh : IsSemiring H}, IsSemiring (G*H).
Proof.
intros. apply BuildIsSemiring.
apply (@prod_is_cmonoid (mag2_add G) _ (mag2_add H) _).
apply (@prod_is_monoid (mag2_mult G) _ (mag2_mult H) _).
apply prod_distrib;apply semiring_distributes.
Defined.

Canonical Structure prod_semiring : forall {G H : semiring}, semiring
 := fun G H => BuildSemiring (G*H) prod_is_semiring.

Instance prod_is_ring : forall {G} {Hg : IsRing G}
{H} {Hh : IsRing H}, IsRing (G*H).
Proof.
intros.
apply easyIsRing. apply prod_is_group.
change (IsMonoid (mag_prod (mag2_mult G) (mag2_mult H))).
apply prod_is_monoid.
apply prod_distrib;apply _.
Defined.

Canonical Structure prod_ring : forall {G H : ring}, ring
 := fun G H => BuildRing (G*H) _.

End Product.


From mathcomp Require Import all_ssreflect.

(******************************************************************************)
(*             Definition of a distance on graph                              *)
(*   connectn r n x == the set of all the elements connected to x in n steps  *)
(*                                                                            *)
(*   `d[t1, t2]_r   == the distance between t1 and t2 in r                    *)
(*                     if they are not connected returns the cardinal of the  *)
(*                     the subtype                                            *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section gdist.

Variable T : finType.
Variable r : rel T.

Fixpoint connectn n x :=
  if n is n1.+1 then \bigcup_(y in (rgraph r x)) connectn n1 y
  else [set x].

Lemma connectnP n x y :
  reflect
    (exists p : seq T, [/\ path r x p, last x p = y & size p = n])
    (y \in connectn n x).
Proof.
elim: n x y =>  [x y|n IH x y /=].
  rewrite inE; apply: (iffP idP) => [/eqP->|[[|a l] [] //= _ ->//]].
  by exists [::].
apply: (iffP idP) => [/bigcupP[i]|[[|i p]//= [H1 H2 H3]]].
- rewrite [i \in _]rgraphK => iRk /IH [p [H1 H2 H3]].
  by exists (i :: p); split; rewrite /= ?(iRk, H3).
- by [].
case/andP: H1 => H11 H12.
have F : i \in rgraph r x by rewrite [_ \in _]rgraphK.
apply: (subsetP (bigcup_sup _ F)).
by apply/IH; exists p; split => //; case: H3.
Qed.

Definition gdist t1 t2 :=
  find (fun n => t2 \in connectn n t1) (iota 0 #|T|).

Local Notation " `d[ t1 , t2 ] " := (gdist t1 t2)
  (format " `d[ t1 ,  t2 ] ").

Lemma gdist_eq0 t1 t2 : (`d[t1, t2] == 0) = (t1 == t2).
Proof.
have tG : #|T| > 0 by rewrite (cardD1 t1).
rewrite /gdist.
case: #|_| tG => // n _.
rewrite (iotaD _ 1) /= inE [t2 == _]eq_sym.
by case: (t1 =P t2).
Qed.

Lemma gdist_gt0 t1 t2 : (0 < `d[t1, t2]) = (t1 != t2).
Proof. by rewrite ltnNge leqn0 gdist_eq0. Qed.

Lemma gdist0 t : `d[t, t] = 0.
Proof. by apply/eqP; rewrite gdist_eq0. Qed.

Lemma gdist_card_le t1 t2 : `d[t1, t2] <= #|T|.
Proof.
rewrite -[#|T|](size_iota 0).
apply: find_size.
Qed.

Lemma gdist_path_le t1 t2 p :
  path r t1 p -> last t1 p = t2 -> `d[t1, t2] <= size p.
Proof.
move=> Hp Hl.
have [tLp|pLt] := leqP #|T| (size p).
  apply: leq_trans tLp.
  by apply: gdist_card_le.
have F : t2 \in connectn (size p) t1.
  by apply/connectnP; exists p.
case: leqP => // /(before_find _) // /(_ 0).
by rewrite seq.nth_iota // F.
Qed.

Lemma gdist_connect t1 t2 : connect r t1 t2 = (`d[t1,t2] < #|T|).
Proof.
apply/connectP/idP=> [[p /shortenP[p' Hp' Hu _ Ht]]|].
  apply: leq_trans (_ : size p' < _).
    by apply: gdist_path_le.
  rewrite -[_.+1]/(size (t1 :: p')) cardE.
  apply: uniq_leq_size => // i.
  by rewrite mem_enum.
rewrite -[#|_|](size_iota 0) -has_find.
move => /hasP[n _ /connectnP [p [H1p H2p H3p]]].
by exists p.
Qed.

Lemma gdist_nconnect t1 t2 : ~~ connect r t1 t2 -> `d[t1,t2] = #|T|.
Proof.
move=> H; apply/eqP.
have := gdist_card_le t1 t2.
by rewrite leq_eqVlt -gdist_connect (negPf H) orbF.
Qed.

(* geodesic path *)
Definition gpath t1 t2 p :=
  [&& path r t1 p, last t1 p == t2 & `d[t1, t2] == size p].

Lemma gpathP t1 t2 p :
  reflect ([/\ path r t1 p, last t1 p = t2 & `d[t1, t2] = size p])
          (gpath t1 t2 p).
Proof.
apply: (iffP and3P) => [[t1Pp /eqP t1pLt2 /eqP t1t2D]|
                        [t1Pp t1pLt2 t1t2D]]; first by split.
by split => //; apply/eqP.
Qed.

Lemma gpath_connect t1 t2 : connect r t1 t2 -> {p | gpath t1 t2 p}.
Proof.
move=> t1Ct2.
case: (pickP [pred p | gpath t1 t2 (p : `d[t1, t2].-tuple T)]) => [p Hp|HC].
  by exists p.
move: (t1Ct2); rewrite gdist_connect => dLT.
absurd False => //.
move: (dLT); rewrite -[#|_|](size_iota 0) -has_find.
move => /(nth_find 0).
rewrite -[find _ _]/`d[t1, t2].
rewrite nth_iota // add0n => /connectnP[p [H1p H2p /eqP H3p]].
have /idP[] := HC (Tuple H3p).
by apply/and3P; split=> //=; apply/eqP=> //; rewrite (eqP H3p).
Qed.

Lemma gpath_last t1 t2 p : gpath t1 t2 p -> last t1 p = t2.
Proof. by case/gpathP. Qed.

Lemma gpath_dist t1 t2 p : gpath t1 t2 p -> `d[t1, t2] = size p.
Proof. by case/gpathP. Qed.

Lemma gpath_path t1 t2 p : gpath t1 t2 p -> path r t1 p.
Proof. by case/gpathP. Qed.

Lemma last_take (A : Type) (p : seq A) t t1 j :
  j <= size p -> last t1 (take j p) = nth t (t1 :: p) j.
Proof.
elim: p t1 j => [t1 [|] //| a l IH t1 [|j]] //= H.
by apply: IH.
Qed.

(* ugly proof !! *)
Lemma gpath_uniq t1 t2 p : gpath t1 t2 p ->  uniq (t1 :: p).
Proof.
move=> gH; apply/(uniqP t1) => i j iH jH.
wlog : i j iH jH / i <= j.
  move=> H; case: (leqP i j) => [iLj|jLi]; first by apply: H.
  by move=> /(@sym_equal _ _ _) /H->; rewrite // ltnW.
rewrite leq_eqVlt => /orP[/eqP->//|iLj].
case/gpathP : gH  => t1Pp t1pLt2 dt1t2E.
case: j jH iLj => j // jH iLj.
case: i iH iLj => [_ _ t1E | ] //.
  pose p1 := drop j.+1 p.
  have t1Pp1 : path r t1 p1.
    move: (t1Pp); rewrite -[p](cat_take_drop j.+1) cat_path.
    rewrite /= in t1E.
    by rewrite (last_take t1) //= -t1E => /andP[].
  have t1p1L : last t1 p1 = t2.
    move: (t1pLt2); rewrite -[p](cat_take_drop j.+1) last_cat.
    rewrite /= in t1E.
    by rewrite (last_take t1) //= -t1E.
  have [] := boolP (`d[t1, t2] <= size p1) => [|/negP[]]; last first.
    by apply: gdist_path_le.
  rewrite leqNgt => /negP[].
  rewrite size_drop dt1t2E.
  rewrite /= in t1E.
  by rewrite -{2}[size p](subnK (_ : j < size p)) // addnS ltnS leq_addr.
move=> i iH; rewrite ltnS => iLj nE.
pose p1 := take i.+1 p ++ drop j.+1 p.
have [] := boolP (`d[t1, t2] <= size p1) => [|/negP[]].
  rewrite leqNgt => /negP[].
  rewrite size_cat size_take size_drop ifT //; last first.
    by rewrite -ltnS in iLj; apply: leq_trans iLj _.
  rewrite dt1t2E -{2}[size p](subnK (_ : j < size _)) //.
  by rewrite addnC ltn_add2l.
apply: gdist_path_le.
  move: t1Pp; rewrite -[p](cat_take_drop i.+1).
  rewrite -[drop _ _](cat_take_drop (j - i)) !cat_path.
  case/and3P => [-> _] /=.
  rewrite !(last_take t1) /=; last first.
  - rewrite size_drop -subSS.
    by apply: leq_sub2r.
  - by apply: leq_trans iLj _; rewrite ltnW //.
  rewrite drop_drop addnS subnK; last by rewrite ltnW.
  congr path.
  move: (nE) => /= ->.
  rewrite -[j - i]prednK //.
  by rewrite /= nth_drop -subnS addnC subnK //.
  by rewrite subn_gt0.
rewrite last_cat (last_take t1) // nE.
by rewrite -t1pLt2 -{3}[p](cat_take_drop j.+1) last_cat (last_take t1).
Qed.

Lemma gpath_catl t1 t2 p1 p2 :
   gpath t1 t2 (p1 ++ p2) -> gpath t1 (last t1 p1) p1.
Proof.
move=> /gpathP[].
rewrite cat_path last_cat => /andP[t1Pp1 t1p1LPp2] t1p1Lp2Lt2 dt1t2E.
apply/gpathP; split => //.
have : `d[t1, last t1 p1] <= size p1 by rewrite gdist_path_le.
rewrite leq_eqVlt => /orP[/eqP//|dLSp1].
have /gpath_connect[p3 /gpathP[H1 H2 H3]] :
   connect r t1 (last t1 p1) by apply/connectP; exists p1.
have : size (p3 ++ p2) < `d[t1, t2] by rewrite dt1t2E !size_cat -H3 ltn_add2r.
rewrite ltnNge => /negP[].
apply: gdist_path_le; first by rewrite cat_path H1 // H2.
by rewrite last_cat H2.
Qed.

Lemma gpath_catr t1 t2 p1 p2 :
   gpath t1 t2 (p1 ++ p2) -> gpath (last t1 p1) t2 p2.
Proof.
move=> /gpathP[].
rewrite cat_path last_cat => /andP[t1Pp1 t1p1LPp2] t1p1Lp2Lt2 dt1t2E.
apply/gpathP; split => //.
have : `d[last t1 p1, t2] <= size p2 by rewrite gdist_path_le.
rewrite leq_eqVlt => /orP[/eqP//|dLSp1].
have /gpath_connect[p3 /gpathP[H1 H2 H3]] :
   connect r (last t1 p1) t2 by apply/connectP; exists p2.
have : size (p1 ++ p3) < `d[t1, t2] by rewrite dt1t2E !size_cat -H3 ltn_add2l.
rewrite ltnNge => /negP[].
apply: gdist_path_le; first by rewrite cat_path H1 andbT.
by rewrite last_cat.
Qed.

Lemma gdist_cat t1 t2 p1 p2 :
   gpath t1 t2 (p1 ++ p2) ->
   `d[t1,t2] = `d[t1, last t1 p1] + `d[last t1 p1, t2].
Proof.
move=> gH.
rewrite (gpath_dist gH).
rewrite (gpath_dist (gpath_catl gH)) (gpath_dist (gpath_catr gH)) //.
by rewrite size_cat.
Qed.

Lemma gpath_consl t1 t2 t3 p :  gpath t1 t2 (t3 :: p) -> `d[t1, t3] = 1.
Proof. by move=> /(@gpath_catl _ _ [::t3]) /= /gpathP[]. Qed.

Lemma gpath_consr t1 t2 t3 p : gpath t1 t2 (t3 :: p) -> gpath t3 t2 p.
Proof. by move=> /(@gpath_catr _ _ [::t3]). Qed.

Lemma gdist_cons t1 t2 t3 p :
   gpath t1 t2 (t3 :: p) -> `d[t1,t2] = `d[t3, t2].+1.
Proof.
move=> gH.
by rewrite (@gdist_cat _ _ [::t3] p) // (gpath_consl gH).
Qed.

Lemma gdist_triangular t1 t2 t3 : `d[t1, t2] <= `d[t1, t3] + `d[t3, t2].
Proof.
have [/gpath_connect[p pH]|/gdist_nconnect->]
         := boolP (connect r t1 t3); last first.
  by apply: leq_trans (gdist_card_le _ _) (leq_addr _ _).
have [/gpath_connect [p2 p2H] |/gdist_nconnect->]
         := boolP (connect r t3 t2); last first.
  by apply: leq_trans (gdist_card_le _ _) (leq_addl _ _).
rewrite (gpath_dist pH) (gpath_dist p2H) -size_cat.
apply: gdist_path_le.
  rewrite cat_path (gpath_path pH).
  by rewrite (gpath_last pH) (gpath_path p2H).
by rewrite last_cat (gpath_last pH) (gpath_last p2H).
Qed.

Lemma gdist1 t1 t2 : r t1 t2 -> `d[t1, t2] = (t1 != t2).
Proof.
move=> Hr; apply/eqP.
case: (t1 =P t2) => [<-|/eqP HE]; first by rewrite gdist_eq0.
rewrite eqn_leq -{1}[nat_of_bool _]/(size [::t2]) gdist_path_le /= ?andbT //.
by case: gdist (gdist_eq0 t1 t2); rewrite (negPf HE) .
Qed.

Lemma gdist_succ t1 t2 :
  0 < `d[t1, t2] < #|T| -> {t3 | r t1 t3 /\ `d[t3, t2] = `d[t1, t2].-1}.
Proof.
case/andP => dP dT.
move: dT dP.
rewrite -gdist_connect => /gpath_connect[[|t3 p] pH].
  by rewrite (gpath_dist pH).
exists t3; split.
  by have /andP[] := gpath_path (@gpath_catl _ _ [::t3] _ pH).
by rewrite (gdist_cons pH).
Qed.

Lemma gdist_neighboor t1 t2 t3 : r t1 t2 ->
  r t2 t1 -> [|| `d[t2, t3] == `d[t1, t3].-1,
                 `d[t2, t3] == `d[t1, t3] |
                 `d[t2, t3] == `d[t1, t3].+1].
Proof.
move=> t1Rt2 t2Rt1.
have : `d[t1, t3] - `d[t1, t2] <= `d[t2, t3] <= `d[t2, t1] + `d[t1, t3].
  by rewrite leq_subLR !gdist_triangular.
rewrite (gdist1 t1Rt2) (gdist1 t2Rt1).
(do 2 case: eqP) => //= E1 E2; rewrite ?subn0.
- by rewrite -eqn_leq => /eqP->; rewrite eqxx orbT.
- case/andP=> E3.
  rewrite leq_eqVlt => /orP[/eqP->|].
    by rewrite eqxx !orbT.
  rewrite ltnS => E4.
  by rewrite [`d[_, _] == `d[_, _]]eqn_leq E3 E4 orbT.
- case/andP=> E3.
  rewrite leq_eqVlt => /orP[/eqP->|].
    by rewrite eqxx !orbT.
  case: (`d[t1, t3]) E3 => //= d.
  rewrite subSS subn0 ltnS => E3 E4.
  by rewrite [_ == d]eqn_leq E3 E4.
case/andP=> E3.
rewrite leq_eqVlt => /orP[/eqP->|].
  by rewrite eqxx !orbT.
rewrite ltnS leq_eqVlt => /orP[/eqP->|].
  by rewrite eqxx !orbT.
case: (`d[t1, t3]) E3 => //= d.
rewrite subSS subn0 ltnS => E3 E4.
by rewrite [_ == d]eqn_leq E3 E4.
Qed.

End gdist.

Notation " `d[ t1 , t2 ]_ r " := (gdist r t1 t2) (at level 10,
  format "`d[ t1 ,  t2 ]_ r").

Section gdistProp.

Variable T : finType.
Variable r : rel T.

Lemma eq_connectn (r1 r2 : rel T) : r1 =2 r2 -> connectn r1 =2 connectn r2.
Proof.
move=> r1Er2.
elim => //= n IH y; apply: eq_big => // i.
by rewrite ![_ \in _]rgraphK r1Er2.
Qed.

Lemma eq_dist (r1 r2 : rel T) : r1 =2 r2 -> gdist r1 =2 gdist r2.
Proof.
move=> r1Er2 t1 t2.
apply: eq_find => n.
by rewrite (eq_connectn r1Er2).
Qed.

Lemma gdist_sym t1 t2 :
 `d[t1, t2]_r  =  `d[t2, t1]_(fun z : T => r^~ z).
Proof.
apply: eq_find => i.
apply/connectnP/connectnP => /= [] [p [H1p H2p H3p]].
  exists (rev (belast t1 p)); split => //.
  - by rewrite -H2p rev_path.
  - rewrite -H2p; case: (p) => //= a p1.
    by rewrite rev_cons last_rcons.
  by rewrite size_rev size_belast.
exists (rev (belast t2 p)); split => //.
- by rewrite -H2p rev_path.
- rewrite -H2p; case: (p) => //= a p1.
  by rewrite rev_cons last_rcons.
by rewrite size_rev size_belast.
Qed.

Lemma gpath_rev t1 t2 p : gpath r t1 t2 p -> gpath (fun z : T => r^~ z) t2 t1 (rev (belast t1 p)).
Proof.
move=> /gpathP[H1 H2] H3.
apply/gpathP; split => //.
- by rewrite -rev_path H2 in H1.
- case: (p) H2 => //= a p1.
  by rewrite /= rev_cons last_rcons.
by rewrite size_rev size_belast -gdist_sym.
Qed.

Lemma gdistC t1 t2 : symmetric r -> `d[t1, t2]_r  =  `d[t2, t1]_r.
Proof.
move=> rSym; rewrite gdist_sym.
by apply: eq_dist.
Qed.

Lemma eq_gpath (e1 e2 : rel T) t1 t2 c :
    e1 =2 e2 -> gpath e1 t1 t2 c = gpath e2 t1 t2 c.
Proof.
by move=> e1Ee2; apply/gpathP/gpathP; rewrite (eq_path e1Ee2) (eq_dist e1Ee2).
Qed.

Lemma gpathC t1 t2 p :
 symmetric r -> gpath r t1 t2 p -> gpath r t2 t1 (rev (belast t1 p)).
Proof.
move=> hIrr /gpath_rev.
by rewrite (@eq_gpath _ _ _ _ _ (_ : _ =2 r)).
Qed.

End gdistProp.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Syntax.

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

Module Semantics.

Definition andp {model: Type} (X: Ensemble model) (Y: Ensemble model): Ensemble model :=
  fun m => X m /\ Y m.

Definition orp {model: Type} (X: Ensemble model) (Y: Ensemble model): Ensemble model :=
  fun m => X m \/ Y m.

Definition falsep {model: Type}: Ensemble model := fun m => False.

End Semantics.

Class TrivialPropositionalSemantics (L: Language) {minL: MinimumLanguage L} {pL: PropositionalLanguage L} (MD: Model) (SM: Semantics L MD): Type := {
  denote_andp: forall x y, Same_set _ (denotation (x && y)) (Semantics.andp (denotation x) (denotation y));
  denote_orp: forall x y, Same_set _ (denotation (x || y)) (Semantics.orp (denotation x) (denotation y));
  denote_falsep: Same_set _ (denotation FF) Semantics.falsep
}.

Section Trivial.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {MD: Model}
        {SM: Semantics L MD}
        {tpSM: TrivialPropositionalSemantics L MD SM}.

Lemma sat_andp: forall m x y, m |= x && y <-> (m |= x /\ m |= y).
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_andp x y).
  split; auto; [apply H | apply H0].
Qed.

Lemma sat_orp: forall m x y, m |= x || y <-> (m |= x \/ m |= y).
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_orp x y).
  split; auto; [apply H | apply H0].
Qed.

Lemma sat_falsep: forall m, m |= FF <-> False.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct denote_falsep.
  split; auto; [apply H | apply H0].
Qed.

End Trivial.


Inductive light : Set :=
  | Blue   : light
  | Yellow : light
  | Red    : light
.

Definition next x :=
  match x with
  | Blue   => Yellow
  | Yellow => Red
  | Red    => Blue
end.

Print nat.

(*
Inductive nat : Set :=
  | O : nat
  | S : nat -> nat
.
*)

Check (S O).

Eval compute in next (next Yellow).

Theorem light_cycles : forall (l : light), next (next (next l)) = l.
Proof.
  intro p.
  destruct p.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
  simpl.
  reflexivity.
Qed.

Require Import Arith.

Theorem induction_test' : forall n : nat, n + 0 = n.
Proof.
  intro p.
  rewrite plus_comm.
  simpl.
  reflexivity.
Qed.

Theorem induction_test : forall n : nat, n + 0 = n.
Proof.
  intro p.
  induction p.
    simpl.
    reflexivity.

    simpl.
    rewrite IHp.
    reflexivity.

Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Socrates.

Coq < Variables A B C : Prop.
A is assumed
B is assumed
C is assumed

Coq < Goal (A -> B) /\ (C -> A) -> (C -> B).
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  ============================
   (A -> B) /\ (C -> A) -> C -> B

Unnamed_thm < intro H.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  H : (A -> B) /\ (C -> A)
  ============================
   C -> B

Unnamed_thm < intro HA.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  H : (A -> B) /\ (C -> A)
  HA : C
  ============================
   B

Unnamed_thm < apply H.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  H : (A -> B) /\ (C -> A)
  HA : C
  ============================
   A

Unnamed_thm < apply H.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  H : (A -> B) /\ (C -> A)
  HA : C
  ============================
   C

Unnamed_thm < exact HA.
No more subgoals.

Unnamed_thm < Qed.
intro H.
intro HA.
apply H.
apply H.
exact HA.

Unnamed_thm is defined

Coq <
*)

Section Socrates.
Variables A B C : Prop.
Goal (A -> B) /\ (C -> A) -> (C -> B).
intro H.
intro HA.
apply H.
apply H.
exact HA.
Qed.