(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqExt. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : Algebraic hierarchy (use type class) (Setoid version)
  author    : ZhengPu Shi
  date      : 2022.06

  remark    :
  1. The motivate of this module is to support development with good organized
    algebraic hierarchy, instead of scattered def./op./props.
  2. There are three technologies to form a hierarchy: module is a strong
    specification and too heavy; type classes is used in Coq standard library;
    canonical structure is used in mathematical component.
  3. For type classes, ref to this paper "A Gentle Introduction to Type Classes
    and Relations in Coq" and the refrence manual of Coq at
    "https://coq.inria.fr/distrib/V8.13.2/refman/addendum/type-classes.html".
  4. About Q (rational number), we mainly use Qcanon (Qc) instead of Q, hence
    the convenient of equality relation. Precisely, Qc use eq that has best
    built-in support in Coq, rather than Q use Qeq that we should use Setoid
    and write more code to let it work.

  reference :
  1.  Arkansas Tech University / Dr. Marcel B. Finan /
      MATH 4033: Elementary Modern Algebra

  (a) 5 Definition and Examples of Groups
  https://faculty.atu.edu/mfinan/4033/absalg5.pdf
  (b) 14 Elementary Properties of Groups
  https://faculty.atu.edu/mfinan/4033/absalg14.pdf

  2.
  https://math.okstate.edu/people/binegar/3613/3613-l21.pdf

 *)

Require Export BasicConfig.   (* reserved notation *)
Require Export Coq.Classes.RelationClasses. (* binary_relation *)
Require Import Coq.Logic.Description. (* constructive_definite_description *)
Require Export List SetoidList. Import ListNotations.
Require Export Lia Lra.
Require Export Ring Field.
Require Arith ZArith QArith Qcanon Reals.

Set Implicit Arguments.
Unset Strict Implicit.

(* Meanwhile, like A0,A1,... also be availble *)
Generalizable Variables A Aeq Aadd Aopp Amul Ainv Adiv.

(* ######################################################################### *)
(** * Small utilities *)

(** repeat split and intro *)
Ltac split_intro :=
  repeat (try split; try intro).

(** Applicate a unary function for n-times, i.e. f ( .. (f a0) ...) *)
Fixpoint iterate {A} (f : A -> A) (n : nat) (a0 : A) : A :=
  match n with
  | O => a0
  | S n' => f (iterate f n' a0)
  end.

Section test.
  Context {A} {f : A -> A} (A0 : A).
  (* Compute iterate f 3 A0. *)
End test.

(** x is an unique element which holds by P. Setoid version *)
Definition unique_setoid {A: Type} {Aeq: relation A} (P: A -> Prop) (x: A) :=
  P x /\ (forall x' : A, P x' -> Aeq x x').

(** constructive_definite_description, setoid version *)
Axiom constructive_definite_description_setoid :
  forall (A : Type) (Aeq:relation A) (P : A -> Prop),
    (exists x : A, (P x /\ unique_setoid (Aeq:=Aeq) P x)) -> {x : A | P x}.

(** functional_extensionality, setoid version *)
Axiom functional_extensionality_setoid :
  forall {A B} {Beq: relation B} (feq: relation (A->B)) (f g : A -> B),
    (forall a : A, Beq (f a) (g a)) -> feq f g.

(* ######################################################################### *)
(** * Typeclasses Demo *)

(** Example for usage of Class and Instance *)
Module Demo.

  Class Decidable (A:Type) (Aeq:relation A) := {
      decidable : forall (a b : A), {Aeq a b} + {~(Aeq a b)}
    }.

  Inductive Color := Red | Green | Blue.

  Local Instance DecidableColor : @Decidable Color eq.
  Proof. constructor. intros. destruct a,b; try(right;easy);auto. Defined.

  Goal forall c1 c2 :Color, {c1=c2} + {c1<>c2}.
  Proof. apply decidable.  Qed.

  (** Customized Aeq *)
  Inductive ColorEq : Color -> Color -> Prop :=
  | C_RG : ColorEq Red Green
  | C_GB : ColorEq Green Blue.

  Local Instance DecidableColor2 : @Decidable Color ColorEq.
  Proof. constructor. intros. destruct a,b; try (right;easy);auto;
         left; constructor. Qed.

  Goal forall c1 c2 : Color, {ColorEq c1 c2} + {~(ColorEq c1 c2)}.
  Proof. apply decidable. Defined.

End Demo.

(** This example shows that, if we put the parameter of a Class in a Section,
    the the proof canno't automatic find the Instance.
    ToDo: what's the problem? *)
Module Demo2.

  Section sec.
    Variable A : Type.
    Class Commutative (Aop:A->A->A) := {
        commutative : forall a b, Aop a b = Aop b a
      }.
  End sec.

  Local Instance Comm_NatAdd : Commutative Nat.add.
  constructor. auto with arith. Defined.

  Goal forall a b : nat, (a + b = b + a)%nat.
    apply commutative.
    (* Tips: Here, we need to manually specify the Instance, lost the automation *)
    apply Comm_NatAdd.
  Qed.

End Demo2.

(** This example shows that, if we use Context to instead the Variable, then the above
    problem not occur. That means, we can use parameter of a Class in a Section and
    won't lose automation of finding the Instance *)
Module Demo3.

  Section sec.
    Context `{A:Type}.
    Class Commutative (Aop:A->A->A) := {
        commutative : forall a b, Aop a b = Aop b a
      }.
  End sec.

  Local Instance Comm_NatAdd : Commutative Nat.add.
  constructor. auto with arith. Defined.

  Goal forall a b : nat, (a + b = b + a)%nat.
    apply commutative.
  Qed.

End Demo3.

(* ######################################################################### *)
(** * A relation is equivalence relation *)

(** ** Class *)

(* Global Hint Constructors Equivalence : core. *)

(** ** Instances *)

(** eqlistA is a equivalence relation *)
Global Instance Equivalence_eqlistA `{Equiv_Aeq:Equivalence A Aeq}
  : Equivalence (eqlistA Aeq).
Proof. apply eqlistA_equiv. auto. Defined.

(** ** Extra Theories *)

(** ** Examples *)

(* ######################################################################### *)
(** * A relation is decidable, usually for equality relation *)

(** ** Class *)

Class Decidable {A:Type} (Aeq:A->A->Prop) := {
    decidable : forall (a b : A), {Aeq a b} + {~(Aeq a b)};
  }.
(* Global Hint Constructors Decidable : core. *)

(** ** Instances *)

Section Instances.
  Import Arith ZArith Reals.

  (** Note that, the instances of EqDec should be declared transparent to enable
    calculation. That is, use Defined instead of Qed. *)
  Global Instance Decidable_NatEq : Decidable Nat.eq.
  Proof. constructor. apply Nat.eq_dec. Defined.

  Global Instance Decidable_Z : @Decidable Z eq.
  Proof. constructor. apply Z.eq_dec. Defined.

  Global Instance Decidable_R : @Decidable R eq.
  Proof. constructor. apply Req_EM_T. Defined.

  Global Instance Decidable_list `{Dec:Decidable} : Decidable (eqlistA Aeq).
  Proof.
    constructor. intros l1. induction l1.
    - intros l2. destruct l2; auto.
      right. intro. easy.
    - intros l2. destruct l2.
      + right. intro. easy.
      + destruct (decidable a a0), (IHl1 l2); auto.
        * right. intro. inversion H. easy.
        * right. intro. inversion H. easy.
        * right. intro. inversion H. easy.
  Defined.

  Global Instance Decidable_dlist `{Dec:Decidable} : Decidable (eqlistA (eqlistA Aeq)).
  Proof.
    constructor. intros l1. induction l1.
    - intros l2. destruct l2; auto.
      right. intro. easy.
    - intros l2. destruct l2.
      + right. intro. easy.
      + destruct (decidable a l), (IHl1 l2); auto.
        * right. intro. inversion H. easy.
        * right. intro. inversion H. easy.
        * right. intro. inversion H. easy.
  Defined.

End Instances.

(** ** Extra Theories *)
Section Dec_theory.

  Context `{Dec : Decidable}.

  (** Tips: these theories are useful for R type *)

  (** Calculate equality to boolean, with the help of equality decidability *)
  Definition Aeqb (a b : A) : bool := if decidable a b then true else false.

  (** Aeqb is true iff equal. *)
  Lemma Aeqb_true : forall a b, Aeqb a b = true <-> Aeq a b.
  Proof.
    intros. unfold Aeqb. destruct decidable; split; intros; auto;  easy.
  Qed.

  (** Aeqb is false iff not equal *)
  Lemma Aeqb_false : forall a b, Aeqb a b = false <-> ~(Aeq a b).
  Proof.
    intros. unfold Aeqb. destruct decidable; split; intros; auto; try easy.
  Qed.

  Lemma Aeq_reflect : forall a b : A, reflect (Aeq a b) (Aeqb a b).
  Proof.
    intros. unfold Aeqb. destruct (decidable a b); constructor; auto.
  Qed.

End Dec_theory.

(** ** Examples *)
Goal forall a b : nat, {a = b} + {a <> b}.
  apply decidable. Qed.

(* ######################################################################### *)
(** * Respect: an operation respect a relation *)

(** deprecated, replaced with "Proper" in Coq *)

(* (** ** Class *) *)

(* (** A unary operation is respect to the equality relation *) *)
(* Class RespectUnary {A B:Type} (op:A->B) (Aeq:A->A->Prop) (Beq:B->B->Prop) := { *)
(*     respectUnary : forall x y : A, *)
(*       Aeq x y -> Beq (op x) (op y) *)
(*   }. *)

(* (** A binary operation is respect to the equality relation *) *)
(* Class RespectBinary {A B C:Type} (op:A->B->C) *)
(*   (Aeq:A->A->Prop) (Beq:B->B->Prop) (Ceq:C->C->Prop):= { *)
(*     respectBinary : forall x y : A, *)
(*       Aeq x y -> forall x0 y0 : B, Beq x0 y0 -> Ceq (op x x0) (op y y0) *)
(*   }. *)

(* (** ** Instances *) *)

(* (** ** Extra Theories *) *)

(* (** ** Examples *) *)

(* ######################################################################### *)
(** * Associative *)

(** ** Class *)
Class Associative {A:Type} (Aop:A->A->A) (Aeq:A->A->Prop) := {
    associative : forall a b c, Aeq (Aop (Aop a b) c) (Aop a (Aop b c));
  }.

(** ** Instances *)
Global Instance Assoc_NatAdd : Associative Nat.add eq.
constructor. auto with arith. Defined.

(** ** Extra Theories *)
Lemma associative_inv : forall `{Equiv_Aeq : Equivalence A Aeq} {Aop:A->A->A}
                          `{Assoc:Associative A Aop Aeq} a b c,
    Aeq (Aop a (Aop b c)) (Aop (Aop a b) c).
Proof. intros. rewrite -> associative. easy. Qed.

(** ** Examples *)
Goal forall a b c : nat, (a + (b + c) = (a + b) + c)%nat.
  apply associative_inv. Qed.

Goal forall a b c : nat, ((a + b) + c = a + (b + c))%nat.
  apply associative. Qed.

(* ######################################################################### *)
(** * Commutative *)

(** ** Class *)
Class Commutative {A:Type} (Aop:A->A->A) (Aeq:A->A->Prop) := {
    commutative : forall a b, Aeq (Aop a b) (Aop b a)
  }.

(** ** Instances *)
Global Instance Comm_NatAdd : Commutative Nat.add eq.
constructor. auto with arith. Defined.

Global Instance Comm_NatMul : Commutative Nat.mul eq.
constructor. auto with arith. Defined.

(** ** Extra Theories *)

(** ** Examples *)
Goal forall a b : nat, (a + b = b + a)%nat.
  apply commutative. Qed.

Goal forall a b : nat, (a * b = b * a)%nat.
  apply commutative. Qed.

(* ######################################################################### *)
(** * Identity Left/Right *)

(** ** Class *)
Class IdentityLeft {A:Type} (Aop:A->A->A) (Ae:A) (Aeq:A->A->Prop) := {
    identityLeft : forall a, Aeq (Aop Ae a) a
  }.

Class IdentityRight {A:Type} (Aop:A->A->A) (Ae:A) (Aeq:A->A->Prop) := {
    identityRight : forall a, Aeq (Aop a Ae) a
  }.

(** ** Instances *)

(** ** Extra Theories *)

(** ** Examples *)

(* ######################################################################### *)
(** * Inverse Left/Right *)

(** ** Class *)
Class InverseLeft {A:Type} (Aop:A->A->A) (Ae:A) (Aopinv:A->A) (Aeq:A->A->Prop)
  := {
    inverseLeft : forall a, Aeq (Aop (Aopinv a) a) Ae
  }.

Class InverseRight {A:Type} (Aop:A->A->A) (Ae:A) (Aopinv:A->A) (Aeq:A->A->Prop)
  := {
    inverseRight : forall a, Aeq (Aop a (Aopinv a)) Ae
  }.

(** ** Instances *)

(** ** Extra Theories *)

(** ** Examples *)

(* ######################################################################### *)
(** * Distributive *)

(** ** Class *)

(* Class DistributiveUnary {A:Type} (Aadd:A->A->A) (Aopp:A->A) (Aeq:A->A->Prop) := { *)
(*     distributiveUnary : forall a b, *)
(*       Aeq *)
(*         (Aopp (Aadd a b)) *)
(*         (Aadd (Aopp a) (Aopp b)) *)
(*   }. *)

Class DistributiveLeft {A:Type} (Aadd Amul:A->A->A) (Aeq:A->A->Prop) := {
    distributiveLeft : forall a b c,
      Aeq
        (Amul a (Aadd b c))
        (Aadd (Amul a b) (Amul a c))
  }.

Class DistributiveRight {A:Type} (Aadd Amul:A->A->A) (Aeq:A->A->Prop) := {
    distributiveRight : forall a b c,
      Aeq
        (Amul (Aadd a b) c)
        (Aadd (Amul a c) (Amul b c))
  }.

(** ** Instances *)

(** ** Extra Theories *)

(** ** Examples *)

(* ######################################################################### *)
(** * Involution Law *)

(** ** Class *)

(* Class Involution {A : Type} (Aopp : A -> A) (Aeq:A->A->Prop) := { *)
(*     involution : forall a, Aeq (Aopp (Aopp a)) a *)
(*   }. *)

(** ** Instances *)

(** ** Extra Theories *)

(** ** Examples *)

(* ######################################################################### *)
(** * Injective *)

(** ** Class *)

Class Injective {A B : Type} {Aeq: relation A} {Beq: relation B} (phi: A -> B) := {
    injective : forall a1 a2 : A, ~(Aeq a1 a2) -> ~(Beq (phi a1) (phi a2))
  }.

(** ** Instances *)

(** ** Extra Theories *)
Section theory.

  Context {A B : Type} {Aeq: relation A} {Beq: relation B}.

  Notation Injective := (Injective (Aeq:=Aeq) (Beq:=Beq)).

  (** Second form of injective *)
  Definition injective_form2 (phi: A -> B) :=
    forall (a1 a2 : A), Beq (phi a1) (phi a2) -> Aeq a1 a2.

  (** These two forms are equal *)
  Lemma injective_eq_injective_form2 (phi: A -> B) :
    Injective phi <-> injective_form2 phi.
  Proof.
    split; intros.
    - hnf. destruct H as [H]. intros.
      specialize (H a1 a2). apply imply_to_or in H. destruct H.
      + apply NNPP in H. auto.
      + easy.
    - hnf in H. constructor. intros. intro. apply H in H1. easy.
  Qed.

  (** Injective function preserve equal relation *)
  Lemma inj_pres_eq : forall (f : A -> B),
      Injective f -> (forall a1 a2 : A, Beq (f a1) (f a2) -> Aeq a1 a2).
  Proof.
    intros. apply injective_eq_injective_form2 in H. apply H. auto.
  Qed.

End theory.

(** ** Examples *)

(* ######################################################################### *)
(** * Surjective *)

(** ** Class *)

Class Surjective {A B : Type} {Beq: relation B} (phi: A -> B) := {
    surjective : forall (b : B), (exists (a : A), Beq (phi a) b)
  }.

(** ** Instances *)

(** ** Extra Theories *)

(** ** Examples *)

(* ######################################################################### *)
(** * Bijective *)

(** ** Class *)

Class Bijective {A B : Type} {Aeq: relation A} {Beq: relation B} (phi: A -> B) := {
    bijInjective :> Injective (Aeq:=Aeq) (Beq:=Beq) phi;
    bijSurjective :> Surjective (Beq:=Beq) phi
  }.

(** ** Instances *)

(** ** Extra Theories *)
Section theory.
  Context {A B: Type} {Aeq:relation A} {Beq:relation B}.
  Context {Equiv_Aeq:Equivalence Aeq} {Equiv_Beq:Equivalence Beq}.
  Notation Bijective := (Bijective (Aeq:=Aeq) (Beq:=Beq)).
  Infix "=A=" := Aeq (at level 70).
  Infix "=B=" := Beq (at level 70).

  (** There exist inverse function from a bijective function.

      ref: https://stackoverflow.com/questions/62464821/
      how-to-make-an-inverse-function-in-coq

      Tips: there are two methods to formalize "existential", sig and ex.
      ex makes a Prop, sig makes a Type.
      Here, we proof the ex version. the sig version could be derived by an axiom:
      [constructive_definite_description :
      forall (A : Type) (P : A -> Prop), (exists ! x : A, P x) -> {x : A | P x} ]
   *)

  Lemma bij_inverse_exist : forall (phi : A -> B) (Hbij: Bijective phi),
    {psi : B -> A | (forall a : A, (psi (phi a)) =A= a) /\  (forall b : B, phi (psi b) =B= b)}.
  Proof.
    intros. destruct Hbij as [Hinj [Hsurj]].
    apply injective_eq_injective_form2 in Hinj. hnf in *.
    (* Tips, unique is eq version, we need setoid version *)
    (* assert (H : forall b, exists! a, phi a =B= b). *)
    assert (H: forall b, exists a, phi a =B= b /\ unique_setoid (Aeq:=Aeq) (fun x => phi x =B= b) a).
    { intros b.
      destruct (Hsurj b) as [a Ha]. exists a. unfold unique_setoid. repeat split; auto.
      intros a' Ha'. apply Hinj. rewrite Ha. rewrite Ha'. easy. }
    eapply constructive_definite_description_setoid.
    exists (fun b => proj1_sig (constructive_definite_description_setoid (H b))).
    split.
    - split.
      + intros a. destruct (constructive_definite_description_setoid). simpl.
        apply Hinj. auto.
      + intros b. destruct (constructive_definite_description_setoid). simpl. auto.
    - hnf. split.
      + split.
        * intros. destruct (constructive_definite_description_setoid). simpl.
          apply Hinj. auto.
        * intros. destruct (constructive_definite_description_setoid). simpl. auto.
      + intros psi [H1 H2].
        eapply functional_extensionality_setoid.
        intros b. destruct (constructive_definite_description_setoid). simpl.
        assert (phi (psi b) =B= b); auto using H2.
        rewrite <- H0 in b0. apply Hinj in b0. exact b0.
        Unshelve. exact eq.
  Defined.

  (** A bijective function preserve equal relation *)
  (* Lemma bij_pres_eq_forward : forall (f : A -> B), *)
  (*     Bijective f -> (forall (a1 a2 : A), Aeq a1 a2 -> Beq (f a1) (f a2)). *)
  (* Proof. *)
  (*   intros. destruct H as [H1 H2]. *)
  (*   (* I can't prove now. *) *)
  (*   Abort. *)

End theory.

(** ** Examples *)

(* ######################################################################### *)
(** * Homomorphic  *)

(** ** Class *)

Class Homomorphic {A B : Type} {Beq: relation B}
  (fa : A -> A -> A) (fb : B -> B -> B) (phi: A -> B) := {
    homomorphic : forall (a1 a2 : A), Beq (phi (fa a1 a2)) (fb (phi a1) (phi a2))
  }.

(** ** Instances *)

(** ** Extra Theories *)

(* Definition homo_inj (phi : A -> B) : Prop := *)
(*   homomorphic phi /\ injective phi. *)

(* (** phi is a homomorphic and surjective mapping *) *)
(* Definition homo_surj (phi : A -> B) : Prop := *)
(*   homomorphic phi /\ surjective phi. *)

(** ** Examples *)

(* ######################################################################### *)
(** * Homomorphism *)

(** ** Class *)

(** If there exist a homomorphic and surjective mapping from <A,+> to <B,⊕>,
    then we said <A,+> and <B,⊕> is homomorphism *)
Class Homomorphism {A B : Type} {Aeq: relation A} {Beq: relation B}
  (fa : A -> A -> A) (fb : B -> B -> B) := {
    homomorphism : exists (phi: A -> B),
      Homomorphic fa fb phi (Beq:=Beq)
      /\ Surjective phi (Beq:=Beq)
      (* need this condition, although this is not explicit in math. *)
      /\ Proper (Aeq ==> Beq) phi
  }.

(** If there exist two homomorphic and surjective mapping from <A,+> to <B,⊕>
    and from <A,*> to <B,⊗>, then we said <A,+,*> and <B,⊕,⊗> is homomorphism *)
Class Homomorphism2 {A B : Type} {Aeq: relation A} {Beq: relation B}
  (fa ga : A -> A -> A) (fb gb : B -> B -> B) := {
    homomorphism2 : exists (phi: A -> B),
      Homomorphic fa fb phi (Beq:=Beq)
      /\ Homomorphic ga gb phi (Beq:=Beq)
      /\ Surjective phi (Beq:=Beq)
      (* need this condition, although this is not explicit in math. *)
      /\ Proper (Aeq ==> Beq) phi
  }.

(** ** Instances *)

(** ** Extra Theories *)

(** ** Examples *)

(* ######################################################################### *)
(** * Isomorphism *)

(** ** Class *)

(** If there exist a homomorphic and bijective mapping from <A,+> to <B,⊕>,
    then we said <A,+> and <B,⊕> is isomorphism *)
Class Isomorphism {A B : Type} {Aeq: relation A} {Beq: relation B}
  (fa : A -> A -> A) (fb : B -> B -> B) := {
    isomorphism : exists (phi: A -> B),
      Homomorphic fa fb phi (Beq:=Beq)
      /\ Bijective phi (Aeq:=Aeq) (Beq:=Beq)
      (* need this condition, although this is not explicit in math. *)
      /\ Proper (Aeq ==> Beq) phi
  }.

(** If there exist two homomorphic and bijective mapping from <A,+> to <B,⊕>
    and from <A,*> to <B,⊗>, then we said <A,+,*> and <B,⊕,⊗> is isomorphism *)
Class Isomorphism2 {A B : Type} {Aeq: relation A} {Beq: relation B}
  (fa ga : A -> A -> A) (fb gb : B -> B -> B) := {
    isomorphism2 : exists (phi: A -> B),
      Homomorphic fa fb phi (Beq:=Beq)
      /\ Homomorphic ga gb phi (Beq:=Beq)
      /\ Bijective phi (Aeq:=Aeq) (Beq:=Beq)
      (* need this condition, although this is not explicit in math. *)
      /\ Proper (Aeq ==> Beq) phi
  }.

(** ** Instances *)

(** ** Extra Theories *)

(** ** Examples *)

(* ######################################################################### *)
(** * Monoid *)

(** ** Class *)
Class Monoid {A:Type} (Aadd : A -> A -> A) (A0 : A) (Aeq:A->A->Prop) := {
    monoidAaddProper :> Proper (Aeq ==> Aeq ==> Aeq) Aadd;
    monoidEquiv :> Equivalence Aeq;
    monoidAssoc :> Associative Aadd Aeq;
    monoidIdL :> IdentityLeft Aadd A0 Aeq;
    monoidIdR :> IdentityRight Aadd A0 Aeq;
  }.

(** ** Instances *)
Section Instances.

  Import Arith ZArith Qcanon Reals.

  Global Instance Monoid_NatAdd : Monoid Nat.add 0%nat eq.
  split_intro; subst; auto. rewrite Nat.add_assoc; auto. Defined.

  Global Instance Monoid_NatMul : Monoid Nat.mul 1%nat eq.
  split_intro; subst; auto. rewrite Nat.mul_assoc; auto.
  apply Nat.mul_1_l. apply Nat.mul_1_r.
  Defined.

  Global Instance Monoid_ZAdd : Monoid Z.add 0%Z eq.
  split_intro; auto with zarith. Defined.

  Global Instance Monoid_ZMul : Monoid Z.mul 1%Z eq.
  split_intro; auto with zarith. Defined.

  Global Instance Monoid_QcAdd : Monoid Qcplus 0 eq.
  split_intro; subst; auto. rewrite Qcplus_assoc; auto.
  apply Qcplus_0_l. apply Qcplus_0_r.
  Defined.

  Global Instance Monoid_QcMul : Monoid Qcmult 1 eq.
  split_intro; subst; auto. rewrite Qcmult_assoc; auto.
  apply Qcmult_1_l. apply Qcmult_1_r.
  Defined.

  Global Instance Monoid_RAdd : Monoid Rplus 0%R eq.
  split_intro; subst; auto. apply Rplus_assoc.
  apply Rplus_0_l. apply Rplus_0_r.
  Defined.

  Global Instance Monoid_RMul : Monoid Rmult 1%R eq.
  split_intro; subst; auto. apply Rmult_assoc.
  apply Rmult_1_l. apply Rmult_1_r.
  Defined.

End Instances.

(** ** Extra Theories *)
(* What' a theory? a group of properties related to this sturcture *)

(* deprecated *)
(** monoid rewriting, need manualy specify the name of a Instance.
    It is strict, but less automated. *)
Ltac monoid_rw_old M :=
  rewrite (@associative _ _ _ (@monoidAssoc _ _ _ M)) ||
    rewrite (@identityLeft _ _ _ _ (@monoidIdL _ _ _ M)) ||
    rewrite (@identityRight _ _ _ _ (@monoidIdR _ _ _ M)).

Ltac monoid_simpl_old M := intros; repeat monoid_rw_old M; auto.

(** monoid rewriting, automatic inference the Instance. But sometimes it will fail *)
Ltac monoid_rw :=
  rewrite identityLeft ||
    rewrite identityRight ||
    rewrite associative.

Ltac monoid_simpl := intros; repeat monoid_rw; try reflexivity; auto.

(** This example shows that, if we give a theorem that its parameter of a instance
    declaration in a section, then the application of this theorem will fail, and
    need more manually help of inference. *)
Module Demo_ApplyFail.

  Section sec.
    Variable A : Type.
    Variable Aadd : A -> A -> A.
    (* Variable A0 : A. *)
    Context {A0 : A}.
    Variable Aeq : relation A.
    Context {M : @Monoid A Aadd A0 Aeq}.
    Infix "+" := Aadd.
    Notation "1" := A0.
    Infix "==" := Aeq.

    Lemma monoid_assoc : forall a b c, (a + b) + c == a + (b + c).
    Proof.
      apply associative.
    Qed.

  End sec.

  Import Qcanon.

  Local Instance Monoid_QcAdd : Monoid Qcplus 0 eq.
  split_intro; subst; auto. rewrite Qcplus_assoc; auto.
  apply Qcplus_0_l. apply Qcplus_0_r.
  Defined.

  Goal forall a b c : Qc, (a + b) + c = a + (b + c).
    intros.
    (* Fail apply monoid_assoc. *)
    (* Tips: the application of this theorem will fail. We need to specify the A0 *)
    apply monoid_assoc with (A0:=0).
    (* And, the instance won't be automaticly inferenced too, even we use a Context
       syntax to instead the Variable syntax.
       Maybe the behavior is depends on the parameters it used, like A0.
       But, when I modified the A0 with Context, the situation is still bad.
       In the example below, I find that all the parameters need to be
       declared implicited, thus the automation is available. *)
    apply Monoid_QcAdd.
  Qed.

End Demo_ApplyFail.

(** This example shows that, if we use implicit parameter only, the instance
    inference is work well. Thus, the automation is available *)
Module Demo_ApplyFail_Fix.

  Section sec.
    Context `{M:Monoid}.
    Infix "+" := Aadd.
    Notation "1" := A0.
    Infix "==" := Aeq.

    Lemma monoid_assoc : forall a b c, ((a + b) + c) == (a + (b + c)).
    Proof.
      apply associative.
    Qed.

  End sec.

  Import Qcanon.

  Local Instance Monoid_QcAdd : Monoid Qcplus 0 eq.
  split_intro; subst; auto. rewrite Qcplus_assoc; auto.
  apply Qcplus_0_l. apply Qcplus_0_r.
  Defined.

  Goal forall a b c : Qc, (a + b) + c = a + (b + c).
  Proof.
    intros. apply monoid_assoc.
  Qed.

End Demo_ApplyFail_Fix.

Section Theory.
  Context `{M:Monoid}.
  Infix "+" := Aadd : A_scope.
  Infix "==" := Aeq : A_scope.

End Theory.

(** ** Examples *)

Section Examples.

  Import Reals.

  Goal forall a b c : R, ((a * b) * c = a * (b * c))%R.
  Proof.
    apply associative.
  Qed.

End Examples.

(* ######################################################################### *)
(** * Abelian monoid *)

(** ** Class *)
Class AMonoid {A} Aadd A0 Aeq := {
    amonoidMonoid :> @Monoid A Aadd A0 Aeq;
    amonoidComm :> Commutative Aadd Aeq;
  }.

(** ** Instances *)
Section Instances.

  Import Qcanon Reals.

  Global Instance AMonoid_QcAdd : AMonoid Qcplus 0 eq.
  split_intro; subst; ring. Defined.

  Global Instance AMonoid_QcMul : AMonoid Qcmult 1 eq.
  split_intro; subst; ring. Defined.

  Global Instance AMonoid_RAdd : AMonoid Rplus 0%R eq.
  split_intro; subst; ring. Defined.

  Global Instance AMonoid_RMul : AMonoid Rmult 1%R eq.
  split_intro; subst; ring. Defined.

End Instances.

(** ** Extra Theories *)

Ltac amonoid_simpl :=
  monoid_simpl;
  apply commutative.

(* Section Theory. *)

(*   Context `(AM : AMonoid). *)
(*   Infix "*" := op. *)

(*   Lemma amonoid_comm : forall a b, a * b = b * a. *)
(*   Proof. apply comm. Qed. *)

(*   Lemma amonoid_comm' : forall a b, a * b = b * a. *)
(*   Proof. destruct AM. auto. Qed. *)

(* End Theory. *)

(** ** Examples *)
Section Examples.

  Import Qcanon.

  Goal forall a b : Qc, a * b = b * a.
  Proof.
    amonoid_simpl.
  Qed.

End Examples.

(* ######################################################################### *)
(** * Group *)

(** ** Class *)
Class Group {A} Aadd A0 (Aopp : A -> A) Aeq := {
    groupMonoid :> @Monoid A Aadd A0 Aeq;
    groupInvL :> InverseLeft Aadd A0 Aopp Aeq;
    groupInvR :> InverseRight Aadd A0 Aopp Aeq;
    groupAaddProper :> Proper (Aeq ==> Aeq ==> Aeq) Aadd;
    groupAoppProper :> Proper (Aeq ==> Aeq) Aopp;
    (* groupDistrAinv :> DistributiveUnary Aop Ainv Aeq; *)
    (* groupInvoAinv :> Involution Ainv Aeq; *)
  }.

(** ** Instances *)
Section Instances.

  Import Qcanon Reals.

  Global Instance Group_QcAdd : Group Qcplus 0 Qcopp eq.
  split_intro; subst; ring. Defined.

  Global Instance Group_RAdd : Group Rplus 0%R Ropp eq.
  split_intro; subst; ring. Defined.

End Instances.

(** ** Extra Theories *)

Ltac group_rw :=
  rewrite inverseLeft ||
    rewrite inverseRight.

Ltac group_simpl :=
  repeat (group_rw || monoid_rw || group_rw);
  try reflexivity;
  auto.

(*
  Group Theory

  1.  Arkansas Tech University / Dr. Marcel B. Finan /
      MATH 4033: Elementary Modern Algebra

  (a) 5 Definition and Examples of Groups
  https://faculty.atu.edu/mfinan/4033/absalg5.pdf
  (b) 14 Elementary Properties of Groups
  https://faculty.atu.edu/mfinan/4033/absalg14.pdf
 *)
Section GroupTheory.

  Context `{G:Group}.
  Infix "==" := Aeq.
  Infix "+" := Aadd.
  Notation "0" := A0.
  Notation "- a" := (Aopp a).
  Notation Asub := (fun x y => x + (-y)).
  Infix "-" := Asub.

  (** *** Additional properties. *)
  Section additional_props.

    (** - 0 = 0 *)
    Theorem group_opp_zero_eq_zero : - 0 == 0.
    Proof.
      pose proof (inverseLeft 0). rewrite identityRight in H. auto.
    Qed.

    (** Asub is proper morphism *)
    Lemma Asub_aeq_mor : Proper (Aeq ==> Aeq ==> Aeq) Asub.
    Proof.
      unfold Proper, respectful.
      intros. rewrite H,H0. easy.
    Qed.

    Global Existing Instance Asub_aeq_mor.

  End additional_props.

  (** Theorem 5.1 *)
  (* Note that, I give two theorem rather than one. *)
  Theorem group_id_uniq_l : forall e',
      (forall a, e' + a == a) -> e' == 0.
  Proof.
    intros.
    (* e = e' + e = e' *)
    assert (e' == e' + 0). { rewrite identityRight. reflexivity. }
    assert (e' + 0 == 0); auto.
    rewrite H0. rewrite <- H1 at 2. reflexivity.
  Qed.

  Theorem group_id_uniq_r : forall e', (forall a, a + e' == a) -> e' == 0.
  Proof.
    intros.
    (* e = e + e' = e' *)
    assert (0 == 0 + e'). { rewrite H. easy. }
    assert (0 + e' == e') by group_simpl.
    apply transitivity with (0 + e'); auto. group_simpl.
  Qed.

  (* Note that, I give two theorem rather than one. *)
  Theorem group_inv_uniq_l : forall x1 x2 y,
      x1 + y == 0 /\ y + x2 == 0 -> x1 == x2.
  Proof.
    intros. destruct H as [Ha Hb].
    (* x1 == x1+e == x1+(y+x2) == (x1+y)+x2 == e+x2 == x2 *)
    assert (x1 == x1 + 0) by group_simpl.
    rewrite H. rewrite <- Hb. rewrite <- associative.
    rewrite Ha. group_simpl.
  Qed.

  Theorem group_inv_uniq_r :
    (forall x y1 y2, x + y1 == 0 /\ y2 + x == 0 -> y1 == y2).
  Proof.
    intros. destruct H as [Ha Hb].
    (* y1 == e+y1 == (y2+x)+y1 == y2+(x+y1) == y2+e == y2 *)
    assert (y1 == 0 + y1). group_simpl.
    rewrite H. rewrite <- Hb. rewrite associative.
    rewrite Ha. group_simpl.
  Qed.

  (** Theorem 14.1 *)
  Theorem group_cancel_l : forall x y1 y2, x + y1 == x + y2 -> y1 == y2.
  Proof.
    intros.
    (* y1 == e+y1 == (-x+x)+y1 == (-x)+(x+y1) == (-x)+(x+y1)
      == (-x+x)+y1 == e+y1 == y1*)
    rewrite <- identityLeft.
    assert (0 == (-x) + x). group_simpl.
    rewrite H0. rewrite associative. rewrite H.
    rewrite <- associative. group_simpl.
  Qed.

  Theorem group_cancel_r : forall x1 x2 y, x1 + y == x2 + y -> x1 == x2.
  Proof.
    intros.
    (* x1 = x1+e = x1+(y+ -y) = (x1+y)+(-y) = (x2+y)+(-y)
      = x2+(y+ -y) = x2+e = x2 *)
    rewrite <- identityRight.
    assert (0 == y + (-y)). group_simpl.
    rewrite H0. rewrite <- associative. rewrite H.
    rewrite associative. group_simpl.
  Qed.

  Theorem group_inv_inv : forall x,  - - x == x.
  Proof.
    intros. apply group_cancel_l with (- x). group_simpl.
  Qed.

  Theorem group_inv_distr : forall x y, - (x + y) == (- y) + (- x).
  Proof.
    intros.
    (* (x+y)+ -(x+y) = e = x+ -x = x+e+ -x = x+(y+ -y)+ -x
      = (x+y)+(-y+ -x), by cancel_l, got it *)
    apply group_cancel_l with (x + y).
    rewrite inverseRight. rewrite <- associative. rewrite (associative x y).
    group_simpl.
  Qed.

  (** Theorem 14.2 *)
  (* a + x = b -> x = (-a) + b *)
  Theorem group_equation_sol_l : forall a b x, a + x == b -> x == (- a) + b.
  Proof.
    intros.
    (* left mult a *)
    apply group_cancel_l with (a).
    rewrite <- associative. group_simpl.
  Qed.

  (* a + x = b /\ a + y = b -> x = -a + b /\ y = -a + b *)
  Theorem group_equation_sol_l_uniq :
    forall a b x y, (a + x == b /\ a + y == b) -> (x == -a + b /\ y == -a + b).
  Proof.
    intros. destruct H. split.
    apply group_equation_sol_l; auto.
    apply group_equation_sol_l; auto.
  Qed.

  (* x + a = b -> x = b + (-a) *)
  Theorem group_equation_sol_r : forall a b x, x + a == b -> x == b + (- a).
  Proof.
    intros.
    (* right mult a *)
    apply group_cancel_r with (a). group_simpl.
  Qed.

  (* (x + a = b /\ y + a = b) -> (x = b + -a /\ y = b + -a) *)
  Theorem group_equation_sol_r_uniq :
    forall a b x y, (x + a == b /\ y + a == b) -> (x == b + (- a) /\ y == b + (- a)).
  Proof.
    intros; destruct H. split.
    apply group_equation_sol_r; auto.
    apply group_equation_sol_r; auto.
  Qed.

  (** Definition 14.1 (multiple operations) *)
  (* batch : list A -> A
    [] = e
    [a1] = a1
    [a1;a2] = a1 * a2
    [a1;a2;a3] = (a1*a2)*a3
    [a1;a2;...;a_n-1;an] = ((...(a1*a2)* ... )*a_n-1)*an *)
  Definition group_batch (l:list A) :=
    match l with
    | [] => 0
    | x :: l' => fold_left Aadd l' x
    end.

  Section test.
    Variable (a1 a2 a3 a4 : A).

    (* Compute group_batch []. *)
    (* Compute group_batch [a1]. *)
    (* Compute group_batch [a1;a2]. *)
    (* Compute group_batch [a1;a2;a3]. *)
    (* Compute group_batch [a1;a2;a3;a4]. *)

  End test.

  (** Theorem 14.3 (Generalized Associative Law) *)
  Section th14_3.

    Notation "'Σ' a '&' l " := (fold_left Aadd l a) (at level 10).

    Theorem group_assoc_general (l1 l2 : list A) :
      (group_batch l1) + (group_batch l2) ==  group_batch (l1 ++ l2).
    Proof.
      (* reduct to fold_left *)
      destruct l1,l2; simpl; group_simpl.
      - rewrite app_nil_r. group_simpl.
      - rename a into a1, a0 into a2.
        (* H1. forall a l1 l2, Σ a & (l1 ++ l2) = Σ (Σ a & l1) & l2
           H2. forall a b l, a + Σ b & l = Σ (a + b) & l
           H3. forall a b l, Σ a & (b :: l) = Σ (a + b) & l
           by H1, right = Σ (Σ a1 & l1) & (a2 :: l2).
           by H2, left  = Σ ((Σ a1 & l1) + a2) & l2).
           remember (Σ a1 & l1) as c, then goal become to
              Σ (c + a2) & l2 = Σ c & (a2 :: l2)
           by H3, we got it. *)
        assert (forall a l1 l2, Σ a & (l1 ++ l2) == Σ (Σ a & l1) & l2) as H1.
        { intros a l0. gd a. induction l0; intros; try reflexivity.
          simpl. rewrite IHl0. reflexivity. }
        assert (forall a b l, a + Σ b & l == Σ (a + b) & l) as H2.
        { intros. gd b. gd a. induction l; simpl; intros; try reflexivity.
          simpl. rewrite IHl.
          (** fold_left preveres the aeq *)
          assert (forall l a1 a2, a1 == a2 -> Σ a1 & l == Σ a2 & l).
          { induction l0; intros; simpl in *; auto.
            apply IHl0. rewrite H. easy. }
          apply H. group_simpl. }
        assert (forall a b l, Σ a & (b :: l) = Σ (a + b) & l) as H3.
        { intros. gd b. gd a. induction l; auto. }
        rewrite H1. rewrite H2. rewrite H3. easy.
    Qed.

  End th14_3.

  Section th14_4.

    Import ZArith.

    (** Definition 14.2 (power)
      a ^ 0      = e
      a ^ n      = a ^ (n-1) * a, for n >= 1
      a ^ (-n)   = (-a) ^ n,  for n >= 1
     *)
    Definition group_power (a : A) (n : Z) : A :=
      match n with
      | Z0 => 0
      | Zpos m => iterate (fun x => Aadd x a) (Pos.to_nat m) 0
      | Z.neg m => iterate (fun x => Aadd x (Aopp a)) (Pos.to_nat m) 0
      end.
    Infix "^" := group_power.

    Section test.
      Variable (a1 a2 a3 a4 : A).
      (* Compute group_power a1 3. *)
      (* Compute group_power a1 (-3). *)

    End test.

    (** Remark 14.2 *)
    Lemma group_power_eq1 (n : Z) :
      match n with
      | Z0 => forall a, a ^ n = 0
      | Zpos m => forall a, a ^ n = group_batch (repeat a (Z.to_nat n))
      | Zneg m => forall a, a ^ n = group_batch (repeat (-a) (Z.to_nat (-n)))
      end.
    Proof.
      destruct n; intros; auto.
    Admitted.

    (** Theorem 14.4 *)
    Theorem group_power_inv : forall a n, (a^n) + (a^(- n)) = 0.
    Admitted.

    Theorem group_power_plus : forall a m n, (a^m) + (a^n) = a^(m+n).
    Admitted.

    Theorem group_power_mul : forall a m n, (a^m)^n = a^(m*n).
    Admitted.

  End th14_4.

  (** *** Below, these properties are not in textbook *)

  Theorem group_inv_id : - 0 == 0.
  Proof.
    intros.
    (* -e = -e + e = e *)
    rewrite <- identityRight. group_simpl.
  Qed.

End GroupTheory.

(** ** Examples *)
Section Examples.

  Import Reals.

  Goal forall x1 x2 y : R, (x1 + y = 0 /\ y + x2 = 0 -> x1 = x2)%R.
    apply group_inv_uniq_l. Qed.

End Examples.

(* ######################################################################### *)
(** * Abelian Group *)
(* ######################################################################### *)
(** ** Class *)
(** ** Instances *)
(** ** Extra Theories *)
(** ** Examples *)

(* ======================================================================= *)
(** ** Definition and theory *)

Class AGroup {A} Aadd A0 Aopp Aeq := {
    agroupGroup :> @Group A Aadd A0 Aopp Aeq;
    agroupAM :> @AMonoid A Aadd A0 Aeq;
    agroupComm :> Commutative Aadd Aeq;
  }.

Section Theory.

  Context `{AG : AGroup}.
  Infix "+" := Aadd.
  Infix "==" := Aeq.
  Notation "- a" := (Aopp a).
  Notation "a - b" := (a + (-b)).

  Lemma agroup_sub_comm : forall a b, a - b == - (b - a).
  Proof.
    intros.
    rewrite (group_inv_distr). rewrite (group_inv_inv). easy.
  Qed.

  Lemma agroup_sub_perm : forall a b c, (a - b) - c == (a - c) - b.
  Proof.
    intros.
    rewrite ?associative. rewrite (commutative (-b)). easy.
  Qed.

  Lemma agroup_sub_distr : forall a b, - (a + b) == -a + (-b).
  Proof.
    intros. rewrite (group_inv_distr). apply commutative.
  Qed.

  Lemma agroup_sub_assoc : forall a b c, (a - b) - c == a - (b + c).
  Proof.
    intros. rewrite ?associative. rewrite agroup_sub_distr. easy.
  Qed.

End Theory.

(* ======================================================================= *)
(** ** Instances *)
Section Instances.

  Import Qcanon Reals.

  Global Instance AGroup_QcAdd : AGroup Qcplus 0 Qcopp eq.
  split_intro; subst; ring. Defined.

  Global Instance AGroup_RAdd : AGroup Rplus 0%R Ropp eq.
  split_intro; subst; ring. Defined.

  Goal forall a b c : R, ((a - b) - c = a - (b + c))%R.
    intros.
    apply agroup_sub_assoc. Qed.

End Instances.

(* ######################################################################### *)
(** * Ring *)

(** ** Class *)

(* Note that, in mathematics, mul needn't commutative, but ring_theory in Coq
  need it. Because we want use ring tactic, so add this properties. *)
Class Ring {A} Aadd A0 Aopp Amul A1 Aeq := {
    ringAddAG :> @AGroup A Aadd A0 Aopp Aeq;
    ringMulAM :> @AMonoid A Amul A1 Aeq;
    ringDistrL :> DistributiveLeft Aadd Amul Aeq;
    ringDistrR :> DistributiveRight Aadd Amul Aeq;
  }.

(** ** Instances *)
Section Instances.

  Import Qcanon Reals.

  Global Instance Ring_Qc : Ring Qcplus 0 Qcopp Qcmult 1 eq.
  split_intro; subst; ring. Defined.

  Global Instance Ring_R : Ring Rplus R0 Ropp Rmult R1 eq.
  split_intro; subst; ring. Defined.

End Instances.

(** ** Extra Theories *)
Section Theory.

  Context `{R:Ring}.

  Infix "==" := Aeq : A_scope.
  Infix "+" := Aadd : A_scope.
  Notation "- a" := (Aopp a) : A_scope.
  Notation Asub := (fun a b => a + -b)%A.
  Infix "*" := Amul : A_scope.

  Lemma make_ring_theory : ring_theory A0 A1 Aadd Amul Asub Aopp Aeq.
  Proof.
    constructor; intros;
      try (rewrite ?identityLeft,?associative; reflexivity);
      try (rewrite commutative; reflexivity).
    rewrite distributiveRight; reflexivity.
    rewrite inverseRight; reflexivity.
  Qed.

  Add Ring ring_inst : make_ring_theory.

End Theory.

(** ** Examples *)

Section Examples.

  Import Reals.

  Goal forall a b c : R, (a * (b + c) = a * b + a * c)%R.
    apply distributiveLeft. Qed.

End Examples.

(** This example declares an abstract ring structure, and shows how to use fewer code
    to enable "ring" tactic. *)
Module Demo_AbsRing.
  Context `{R:Ring}.
  Infix "+" := Aadd. Infix "*" := Amul. Infix "==" := Aeq.
  Notation "0" := A0. Notation "1" := A1.

  Let ring_thy : ring_theory A0 A1 Aadd Amul (fun x y => Aadd x (Aopp y))
                   Aopp Aeq := make_ring_theory.

  Add Ring ring_thy_inst : ring_thy.

  Goal forall a b c : A, (a + b) * c == 0 + b * c * 1 + 0 + 1 * c * a.
  Proof. intros. ring. Qed.

End Demo_AbsRing.

(** This is a concrete ring structure *)
Module Demo_ConcrateRing.
  (*
A={a b e}.
+ 0 1 2 3
0 0 1 2 3
1 1 2 3 0
2 2 3 0 1

* 0 1 2 3
0 0 0 0 0
1 0 1 2 3
2 0 2 0 2
3 0 3 2 1
   *)
  Inductive A := A0 | A1 | A2 | A3.
  Notation "0" := A0. Notation "1" := A1.
  Notation "2" := A2. Notation "3" := A3.

  Definition add  (a b : A) :=
    match a,b with
    | 0,_ => b
    | 1,0 => 1 | 1,1 => 2 | 1,2 => 3 | 1,3 => 0
    | 2,0 => 2 | 2,1 => 3 | 2,2 => 0 | 2,3 => 1
    | 3,0 => 3 | 3,1 => 0 | 3,2 => 1 | 3,3 => 2
    end.
  Infix "+" := add.

  Definition opp (a:A) :=
    match a with
    | 0 => 0 | 1 => 3 | 2 => 2 | 3 => 1
    end.
  Notation "- a" := (opp a).
  Notation "a - b" := (a + (-b)).

  Definition mul  (a b : A) :=
    match a,b with
    | 0,_ => 0
    | 1,_ => b
    | 2,0 => 0 | 2,1 => 2 | 2,2 => 0 | 2,3 => 2
    | 3,0 => 0 | 3,1 => 3 | 3,2 => 2 | 3,3 => 1
    end.
  Infix "*" := mul.

  Lemma add_comm : forall a b, a + b = b + a.
  Proof. destruct a,b; auto. Qed.

  Lemma ring_thy : ring_theory 0 1 add mul (fun x y => add x (opp y)) opp eq.
  Proof.
    constructor; auto;
      try (destruct x,y; auto); try destruct z; auto.
    intros. destruct x; auto.
  Qed.

  Add Ring ring_thy_inst : ring_thy.

  Goal forall a b c : A, a + b + c - b = a + c.
  Proof.
    (* Tips, the proof is simple *)
    intros. ring.
  Qed.

End Demo_ConcrateRing.

(* ######################################################################### *)
(** * Field *)

(** ** Class *)
Class Field {A} Aadd A0 Aopp Amul A1 Ainv Aeq := {
    (** Field: Ring + mult inversion + (1≠0) *)
    fieldRing :> @Ring A Aadd A0 Aopp Amul A1 Aeq;
    field_mulInvL : forall a, ~(Aeq a A0) -> Aeq (Amul (Ainv a) a) A1;
    field_1_neq_0 : ~(Aeq A1 A0);
    (** additional: Ainv is proper morphism *)
    fieldAinvProper :> Proper (Aeq ==> Aeq) Ainv
  }.

(** ** Instances *)
Section Instances.

  Import Qcanon Reals.

  Global Instance Field_Qc : Field Qcplus 0 Qcopp Qcmult 1 Qcinv eq.
  split_intro; subst; (try (field; reflexivity)); try easy.
  field. auto.
  Defined.

  Global Instance Field_R : Field Rplus R0 Ropp Rmult R1 Rinv eq.
  split_intro; subst; try (field; reflexivity); auto.
  field; auto. auto with real.
  Defined.

End Instances.

(** ** Extra Theories *)
Section Theory.

  Context `{F:Field}.
  Infix "==" := Aeq : A_scope.
  Infix "!=" := (fun x y => ~ x == y)%A : A_scope.
  Infix "+" := Aadd : A_scope.
  Notation "- a" := (Aopp a) : A_scope.
  Notation Asub := (fun a b => a + -b)%A.
  Notation "0" := A0 : A_scope.
  Notation "1" := A1 : A_scope.
  Infix "*" := Amul : A_scope.
  Notation "/ a" := (Ainv a) : A_scope.
  Notation Adiv := (fun a b => a * (/b))%A.
  Infix "/" := Adiv : A_scope.

  Lemma make_field_theory :
    field_theory A0 A1 Aadd Amul Asub Aopp Adiv Ainv Aeq.
  Proof.
    constructor; intros;
      try (rewrite ?identityLeft,?associative; reflexivity);
      try (rewrite commutative; reflexivity).
    apply make_ring_theory.
    apply field_1_neq_0.
    apply field_mulInvL. auto.
  Qed.

  Add Field field_inst : make_field_theory.

  (** a <> 0 -> /a * a = 1 *)
  Lemma field_mul_inv_l : forall a : A, ~(a == 0)%A -> (/a * a == 1)%A.
  Proof. intros. rewrite field_mulInvL; easy. Qed.

  (** a <> 0 -> a * /a = 1 *)
  Lemma field_mul_inv_r : forall a : A, ~(a == 0)%A -> (a * /a == 1)%A.
  Proof. intros. rewrite commutative. rewrite field_mulInvL; easy. Qed.

  (** a <> 0 -> (1/a) * a = 1 *)
  Lemma field_mul_inv1_l : forall a : A, ~(a == 0)%A -> ((A1/a) * a == 1)%A.
  Proof. intros. simpl. group_simpl. apply field_mul_inv_l. auto. Qed.

  (** a <> 0 -> a * (1/a) = 1 *)
  Lemma field_mul_inv1_r : forall a : A, ~(a == 0)%A -> (a * (A1/a) == 1)%A.
  Proof. intros. simpl. group_simpl. apply field_mul_inv_r. auto. Qed.

  (** a <> 0 -> a * b = a * c -> b = c *)
  Lemma field_mul_cancel_l : forall a b c : A,
      (a != 0)%A -> (a * b == a * c)%A -> (b == c)%A.
  Proof.
    intros.
    assert (/a * (a * b) == /a * (a * c))%A.
    { rewrite H0. easy. }
    rewrite <- ?associative in H1.
    rewrite field_mulInvL in H1; auto.
    rewrite ?identityLeft in H1. easy.
  Qed.

  (** c <> 0 -> a * c = b * c -> a = b *)
  Lemma field_mul_cancel_r : forall a b c : A,
      (c != 0)%A -> (a * c == b * c)%A -> (a == b)%A.
  Proof.
    intros.
    assert ((a * c) * /c == (b * c) * /c)%A.
    { rewrite H0. easy. }
    rewrite ?associative in H1.
    rewrite field_mul_inv_r in H1; auto.
    rewrite ?identityRight in H1. easy.
  Qed.

  (** a * b = 0 -> a = 0 \/ b = 0 *)
  Lemma field_mul_eq0_imply_a0_or_b0 : forall (a b : A) (HDec:Decidable Aeq),
      (a * b == 0)%A -> (a == 0)%A \/ (b == 0)%A.
  Proof.
    intros.
    destruct (decidable a 0)%A, (decidable b 0)%A;
      try (left; easy); try (right; easy).
    assert (/a * a * b == 0)%A.
    { rewrite associative. rewrite H. field. auto. }
    rewrite field_mulInvL in H0; auto.
    rewrite identityLeft in H0. easy.
  Qed.

End Theory.

(** ** Examples *)
Section Examples.

  Import Reals.

  Goal forall a b : R, (a <> 0 -> /a * a = 1)%R.
    intros. apply field_mulInvL. auto. Qed.

End Examples.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From CompDecModal.libs
 Require Import edone bcase fset base modular_hilbert sltype.

Set Default Proof Using "Type".

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * K in Coq  *)

(** ** Formulas *)

Definition var := nat.

Inductive form :=
| fF
| fV   of var
| fImp of form & form
| fAX  of form.

Lemma eq_form_dec (s t : form) : { s = t} + { s <> t}.
Proof. decide equality; apply eq_comparable. Qed.

Definition form_eqMixin := EqMixin (compareP eq_form_dec).
Canonical Structure form_eqType := Eval hnf in @EqType form form_eqMixin.

(** To use formulas and other types built around formulas as base type
for the finite set libaray, we need to show that formulas are
countable. We do this by embedding formulas into the Ssreflect's
generic trees *)

Module formChoice.
  Import GenTree.

  Fixpoint pickle (s : form) :=
    match s with
      | fV v => Leaf v
      | fF => Node 0 [::]
      | fImp s t => Node 1 [:: pickle s ; pickle t]
      | fAX s => Node 2 [:: pickle s]
    end.

  Fixpoint unpickle t :=
    match t with
      | Leaf v  => Some (fV v)
      | Node 0 [::]  => Some (fF)
      | Node 1 [:: t ; t' ] =>
          obind (fun s => obind (fun s' => Some (fImp s s')) (unpickle t')) (unpickle t)
      | Node 2 [:: t ] => obind (fun s => Some (fAX s)) (unpickle t)
      | _ => None
    end.

  Lemma pickleP : pcancel pickle unpickle.
  Proof. move => s. by elim: s => //= [s -> t ->| s -> ]. Qed.
End formChoice.

Definition form_countMixin := PcanCountMixin formChoice.pickleP.
Definition form_choiceMixin := CountChoiceMixin form_countMixin.
Canonical Structure form_ChoiceType := Eval hnf in ChoiceType form form_choiceMixin.
Canonical Structure form_CountType := Eval hnf in CountType form form_countMixin.

(** ** Models

We distinguish thee classes of models

- raw models or transition systems ([ts]): The satisfaction relation [eval] is
  defined on this class

- finite models ([fmodel]): models where the type of states is finite and
  everything else is decidable

- classical models, i.e., models where [eval] is logically decidable ([cmodel]):
  This is the largest class of models for which we can show soundness of the
  hilbert system. *)

Definition stable X Y (R : X -> Y -> Prop) := forall x y, ~ ~ R x y -> R x y.
Definition ldec X Y (R : X -> Y -> Prop) := forall x y, R x y \/ ~ R x y.

Record ts := TS {
  state  :> Type;
  trans  : state -> state -> Prop;
  label  : var -> state -> Prop
}.
Prenex Implicits trans.

Record fmodel := FModel {
  fstate :> finType;
  ftrans : rel fstate;
  flabel : var -> pred fstate
}.
Prenex Implicits ftrans.

(** Make ts inferable for states of fmodels *)
Canonical ts_of_fmodel (M : fmodel) : ts := TS (@ftrans M) (@flabel M).
Coercion ts_of_fmodel : fmodel >-> ts.

Section Characterizations.
  Variables (X : Type) (e : X -> X -> Prop).
  Definition cEX (p : X -> Prop) (w : X) : Prop := exists2 v, e w v & p v.
  Definition cAX (p : X -> Prop) (w : X) : Prop := forall v, e w v -> p v.
End Characterizations.

Fixpoint eval (M:ts) (s : form) :=
  match s with
    | fF       => (fun _ => False)
    | fV v     => label v
    | fImp s t => (fun w => eval M s w -> eval M t w)
    | fAX s    => cAX (@trans M) (eval M s)
  end.

Record cmodel := CModel { sts_of :> ts; modelP : ldec (@eval sts_of) }.

(** * Hilbert System *)

Section Hilbert.
  Local Notation "s ---> t" := (fImp s t).

  Inductive prv : form -> Prop :=
  | rMP s t : prv (s ---> t) -> prv s -> prv t
  | axK s t : prv (s ---> t ---> s)
  | axS s t u : prv ((u ---> s ---> t) ---> (u ---> s) ---> u ---> t)
  | axDN s : prv (((s ---> fF) ---> fF)  ---> s)
  | rNec s : prv s -> prv (fAX s)
  | axN s t : prv (fAX (s ---> t) ---> fAX s ---> fAX t)
  .

  (** The hilbert system for K can be seen as a combination of a Hilbert system
  for minimal logic (M) with classical reasoning (P), and the rules/axioms for
  normal modal logics (K). *)

  Canonical Structure prv_mSystem := MSystem rMP axK axS.
  Canonical Structure prv_pSystem := PSystem axDN.
  Canonical Structure prv_kSystem := KSystem rNec axN.

  Definition valid s := forall (M:cmodel) (w:M), eval s w.

  (** ** Soundness

   The Hilbert System is sound for classical models. *)

  Lemma soundness s : prv s -> forall (M:cmodel) (w:M), eval s w.
  Proof.
    elim => {s} ; try by [move => /= *; firstorder].
    move => /= s M w H. by case: (modelP s w); firstorder.
  Qed.

  (** With excluded middle, every model is a classical model, and the
  Hilbert system is sound for all models *)

  Lemma xm_soundness (xm : XM) s :
    prv s -> forall (M : ts) (w : M), eval s w.
  Proof.
    move => H M w.
    have ldec_ts : ldec (@eval M) by move => ? ?; exact: xm.
    exact: (@soundness _ H (CModel ldec_ts)).
  Qed.

  Lemma XM_required :
    (forall s, prv s -> forall (M : ts) (w : M), eval s w) -> XM.
  Proof.
    move => snd.
    suff S : (forall P, ~ ~ P -> P).
    { move => P. apply: S => C. apply: (C). right => p. apply C. by left. }
    move => P.
    pose L (p : var) (w :unit) := P.
    pose R (w v : unit) := True.
    pose M := TS R L.
    exact: (@snd _ (axDN (fV 0)) M tt).
Qed.

End Hilbert.

(** ** Finite Models

A model is finite, if the underlying type of states is a finite type and the
transition relation and the labeling are decidable. We show that the Hilbert
system is sound for finite models. For this we show that [eval] is decidable on
finite models. *)

Section FiniteModels.
  Variables (M : fmodel).

  Fixpoint evalb s : pred M :=
    match s with
    | fV p => flabel p
    | fF => xpred0
    | fImp s t => fun w => evalb s w ==> evalb t w
    | fAX s => fun w => [forall (v | ftrans w v) , evalb s v]
  end.

  Lemma evalP (w:M) s : reflect (@eval M s w) (evalb s w).
  Proof.
    elim: s w => //=.
    - by constructor.
    - move => * ; exact: idP.
    - move => s IHs t IHt w.
      apply: iffP (@implyP _ _) _ _ => ? /IHs ?; apply/IHt; firstorder.
    - move => s IHs w.
      apply: iffP (@forall_inP _ _ _) _ _ => H v /H /IHs; done.
  Qed.

  Lemma fin_modelP : ldec (@eval M).
  Proof. move => s w. case : (decP (evalP w s)); tauto. Qed.

End FiniteModels.

Canonical cmodel_of_fmodel (M : fmodel) := CModel (@fin_modelP M).
Coercion cmodel_of_fmodel : fmodel >-> cmodel.

(** * Signed Formulas, Clauses, and Support *)

(** ** Signed Formulas

Our decision methods employ signed formulas. we also define a number of
inversion lemmas and other useful constructiuons *)

Definition sform  := (form * bool) %type.
Notation "s ^-" := (s,false) (at level 20, format "s ^-").
Notation "s ^+" := (s,true) (at level 20, format "s ^+").

Definition interp s := match s with (t,true) => t | (t,false) => fImp t fF end.

Definition body s := match s with fAX t^+ => t^+ | fAX t^- => t^- | _ => s end.

Definition isBox s := if s is fAX s^+ then true else false.

Inductive isBox_spec s : bool -> Type :=
| isBox_true t : s = fAX t^+ -> isBox_spec s true
| isBox_false  : isBox_spec s false.

Lemma isBoxP s : isBox_spec s (isBox s).
Proof. move: s => [ [|?|? ?|?] [|]] /=; try constructor. exact: isBox_true. Qed.

Definition isDia s := if s is fAX s^- then true else false.

Inductive isDia_spec s : bool -> Type :=
| isDia_true t : s = fAX t^- -> isDia_spec s true
| isDia_false  : isDia_spec s false.

Lemma isDiaP s : isDia_spec s (isDia s).
Proof. move: s => [ [|?|? ?|?] [|]] /=; try constructor. exact: isDia_true. Qed.

(** ** Clauses and Support *)

Definition clause := {fset sform}.
Implicit Types C D : clause.

Definition sat (M:cmodel) C := exists (w:M), forall s, s \in C -> eval (interp s) w.

(** Local Consistency *)

Definition lcons (L : clause) :=
  (fF^+ \notin L) && [all s in L, if s is fV p^+ then fV p^- \notin L else true].

(** Literals and Support *)

Definition literal (s : sform) :=
  let: (t,_) := s in
  match t with
    | fV _ => true
    | fAX _ => true
    | fF    => true
    | _ => false
  end.

Fixpoint supp (L : clause) u b :=
    match u,b with
      | fImp s t,true  => supp L s false || supp L t true
      | fImp s t,false => supp L s true && supp L t false
      | _,_ => (u,b) \in L
    end.

(** For a locally consistent clause [L], the collection of formulas
supported by [L] corresponds to an (infinite) Hintikka set. *)

Notation "C |> s ^ b" := (supp C s b) (at level 30, format "C  |>  s ^ b").
Notation "C |> s ^+"  := (supp C s true) (at level 30, format "C  |>  s ^+").
Notation "C |> s ^-"  := (supp C s false) (at level 30, format "C  |>  s ^-").
Notation "C |> s"     := (supp C s.1 s.2) (at level 30).

(** Would like to use
[Definition supp' L (s : sform) := let: (t,b) := s in supp L t b.]
[Notation "L |> t" := (supp' L t) (at level 30)]
However, simplification then breaks the notation *)

Lemma supp_mon L1 L2 s : L1 `<=` L2 -> L1 |> s -> L2 |> s.
Proof.
  move/subP => sub. case: s.
  elim => //= [|p|s IHs t IHt|s IHs] [|];
    solve [exact: sub| rewrite -?(rwP orP,rwP andP); intuition].
Qed.

Fixpoint f_weight (s : form) :=
  match s with
    | fImp s t => (f_weight s + f_weight t).+1
    | _        => 0
  end.

Lemma sweight_lit s : f_weight s.1 = 0 <-> literal s.
Proof. case: s => [[|p|s t|s] [|]] //. Qed.

Lemma supp_lit C s b : literal (s,b) -> supp C s b = ((s,b) \in C).
Proof. by case: s. Qed.

Definition form_slClass := SLClass supp_mon supp_lit sweight_lit.
Canonical Structure form_slType := SLType form_slClass.
Canonical Structure form_slpType := @SLPType prv_pSystem form_slClass.

(** Want suppC on singletons to expose the concrete support operation, not the
abstract one *)
Lemma suppC1 L s : suppC L [fset s] = L |> s.
Proof. exact: all_fset1. Qed.

Lemma satA (M:cmodel) (w:M) C :
  (forall s, s \in C -> eval (interp s) w) <-> eval [af C] w.
Proof.
  case: C => xs i /=.
  change ((forall s, s \in xs -> eval (interp s) w) <-> eval [af xs] w).
  elim: xs {i} => [|/= s xs IH]. rewrite big_nil forall_nil /=. tauto.
  rewrite big_cons forall_cons IH {2}/And /=.
  move: (modelP (interp s) w) (modelP [af xs] w); tauto.
Qed.

Lemma href_sound C : prv ([af C] ---> Bot) -> ~ (exists M : cmodel, sat M C).
Proof. move => H [M] [w] /satA X. exact: soundness H M w X. Qed.

(** ** Request *)

Definition R C := [fset body s | s <- [fset t in C | isBox t]].

Lemma RE C s : (s^+ \in R C) = (fAX s^+ \in C).
Proof.
  apply/fimsetP/idP => [ [t] | H].
  - rewrite inE andbC. by case: (isBoxP t) => //= t' -> /= ? [->].
  - exists (fAX s^+) => //. by rewrite inE H.
Qed.

Lemma Rpos s C : s^- \notin R C.
Proof.
  apply/negP. case/fimsetP => t. rewrite inE andbC.
    by case (isBoxP t) => // t' ->.
Qed.

Lemma RU (C C' : clause) : R (C `|` C') = (R C `|` R C').
Proof. by rewrite /R sepU fimsetU. Qed.

Lemma R1 (s : sform) : R [fset s] = if s is fAX u^+ then [fset u^+] else fset0.
Proof. case: s => [[|p|s t|s] [|]]; by rewrite /R sep1 /= ?fimset1 ?fimset0. Qed.

Lemma R0 : R fset0 = fset0.
Proof. by rewrite /R sep0 fimset0. Qed.

Lemma box_request (C : clause) : prv ([af C] ---> AX [af R C]).
Proof.
  rewrite <- bigABBA. apply: bigAI. case => [s [|]]; last by rewrite (negbTE (Rpos _ _)).
  rewrite RE. exact: bigAE.
Qed.

(** ** Subformula Closure *)

Fixpoint ssub' b s :=
  (s,b) |` match s with
             | fImp s t => ssub' (negb b) s `|` ssub' b t
             | fAX t => ssub' b t
             | _ => fset0
           end.

Lemma ssub'_refl s b : (s,b) \in ssub' b s.
Proof. case: s => [|x|s t|s] /=; by rewrite !inE. Qed.

Definition ssub (s : sform) := let (t,b) := s in (ssub' b t).

Lemma ssub_refl s : s \in ssub s.
Proof. case: s. exact: ssub'_refl. Qed.

Definition sf_closed' (F : {fset sform}) (s:sform) :=
  match s with
    | (fImp s t,b) => ((s,negb b) \in F) && ((t,b) \in F)
    | (fAX s, b) => (s,b) \in F
    | _ => true
  end.
Arguments sf_closed' F !s.

Definition sf_closed (F :{fset sform}) := forall s, s \in F -> sf_closed' F s.

Lemma sf_closed'_mon (X Y : clause) s : sf_closed' X s -> X `<=` Y -> sf_closed' Y s.
Proof.
  case: s. elim => [|x|s IHs t IHt|s IHs] b H /subP sub //=;
    rewrite ?sub //=; by [case/andP: H | case/and3P: H].
Qed.

Lemma sf_ssub F s : sf_closed F -> s \in F -> ssub s `<=` F.
Proof.
  case: s. elim => [|p|s IHs t IHt|s IHs] [|] sfc_F inF //=;
   rewrite ?fsetU0 ?fsubUset ?fsub1 ?inF ?IHs ?IHt ?andbT //=;
   move: (sfc_F _ inF) => /=; try bcase.
Qed.

Lemma sfc_ssub s : sf_closed (ssub s).
Proof.
  case: s.
  elim => [|x|s IHs t IHt|s IHs] b //= u; rewrite !inE ?orbF.
  - by move/eqP => -> /=.
  - by move/eqP => -> /=.
  - case/orP => [/eqP ->|H] /=. by rewrite !inE !ssub'_refl.
    apply: sf_closed'_mon (fsubUr _ _).
    case/orP: H => H. apply: sf_closed'_mon (fsubUl _ _). exact: IHs.
    apply: sf_closed'_mon (fsubUr _ _). exact: IHt.
  - case/orP => [/eqP ->|H] /=. by rewrite !inE !ssub'_refl.
    apply: sf_closed'_mon (fsubUr _ _). exact: IHs.
Qed.

Lemma sfcU (X Y : {fset sform}) : sf_closed X -> sf_closed Y -> sf_closed (X `|` Y).
Proof.
  rewrite /sf_closed => /= H1 H2 s.
  case/fsetUP => [/H1 | /H2] H; apply: sf_closed'_mon H _; auto with fset.
Qed.

Definition sfc C : clause := \bigcup_(s in C) ssub s.

Lemma sfc_bigcup (T : choiceType) (C : {fset T}) F :
  (forall s, sf_closed (F s)) -> sf_closed (\bigcup_(s in C) F s).
Proof.
  move => H. apply: big_rec => [s|i D _]; by [rewrite inE|exact: sfcU].
Qed.

Lemma closed_sfc C : sf_closed (sfc C).
Proof. exact: sfc_bigcup sfc_ssub. Qed.

Lemma sub_sfc C : C `<=` (sfc C).
Proof.
  rewrite /sfc. apply/subP => s inC. apply/cupP.
  exists s => //. by rewrite inC ssub_refl.
Qed.

Lemma inU_sfc C : C \in powerset (sfc C).
Proof. by rewrite powersetE sub_sfc. Qed.

#[export] Hint Resolve closed_sfc inU_sfc : core.

Lemma RinU (F : clause) : sf_closed F ->
  forall C, C \in powerset F -> R C \in powerset F.
Proof.
  move => sfc_F C. rewrite !powersetE => /subP H. apply/subP => s.
  case: s => s [|]; last by rewrite (negbTE (Rpos _ _)).
  by rewrite RE => /H /sfc_F.
Qed.

(** ** Size of Subformula Universes *)

Fixpoint f_size (s : form) :=
  match s with
    | fF => 1
    | fV p => 1
    | fImp s t => (f_size s + f_size t).+1
    | fAX s => (f_size s).+1
  end.

Lemma size_ssub (s : form) (b : bool) : size (ssub (s,b)) <= f_size s.
Proof.
  elim: s b => //= [|p|s IHs t IHt|s IHs] b;
    try by rewrite fsetU0 fset1Es.
  - apply: leq_trans (fsizeU1 _ _) _. apply: leq_ltn_trans (fsizeU _ _) _.
    rewrite ltnS. exact: leq_add.
  - apply: leq_trans (fsizeU1 _ _) _. by rewrite ltnS.
Qed.


Require Coq.extraction.Extraction.
Require Import Ascii String Coq.Strings.Byte.
From Coq Require Import Lists.List.
Import ListNotations.
Require Export ExtrOcamlChar.
Extract Inductive bool => "bool" ["true" "false"].
Extract Inductive string => "char list" [ "[]" "(::)" ].
Extract Inductive list => "list" [ "[]" "(::)" ].
Extraction Language OCaml.
Load "../std".

Inductive ty : Type :=
| Bool
|Arrow (ty1 ty2: ty).
Notation "t1 '|-->' t2" := (Arrow t1 t2) (at level 40).

Inductive term : Type :=
(*純粋λ計算*)
| Var (n: nat)
| Abs (name: string) (typ: ty) (t: term)
| App (t1 t2: term)
(*ぶーる*)
| Tru
| Fls
| If (t1 t2 t3: term).

Inductive value : term -> Prop :=
| V_tru : value Tru
| V_fls : value Fls
| V_abs :forall typ name t1, value (Abs typ name t1).

Definition context : Type :=
  list (string * ty).

Definition eqb_string s1 s2:=
  String.eqb s1 s2.

Fixpoint getbinding (n : nat) (ctx: context) :=
  match n with
  | 0 =>
    match ctx with
    | [] => None
    | (x, t) :: ctx' => Some t
    end
  | S n' =>
    match ctx with
    | [] => None
    | x :: ctx' => getbinding n' ctx'
    end
  end.

Definition isval t:=
match t with
| Tru => true
| Fls => true
| Abs _ _ _ => true
| _ => false
end.

Fixpoint eqb_ty (T1 T2: ty) : bool :=
  match (T1, T2) with
  | (Bool, Bool) => true
  | (T11 |--> T12, T21 |--> T22) =>
    andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | _ => false
  end.

Fixpoint inb (ctx: context) (name: string) (T: ty): bool :=
  match ctx with
    | [] => false
    | (n1, b) :: m =>
      if andb (eqb_string name n1) (eqb_ty T b) then
        true
      else inb m name T
  end.

Reserved Notation "ctx '|-' x '\in' t" (at level 40).
Inductive has_type : context -> term -> ty -> Prop :=
| T_True:
    forall ctx,
      ctx |- Tru \in Bool
| T_False:
    forall ctx,
      ctx |- Fls \in Bool
| T_If:
    forall ctx t1 t2 t3 T',
      ctx |- t1 \in Bool ->
      ctx |- t2 \in T' ->
      ctx |- t3 \in T' ->
      ctx |- (If t1 t2 t3) \in T'
| T_Var:
    forall ctx n1 t,
      getbinding n1 ctx = Some t ->
      ctx |- (Var n1) \in t
| T_Abs:
    forall ctx x T1 t2 T2,
      ((x, T1) :: ctx) |- t2 \in T2 ->
      ctx |- (Abs x T1 t2) \in (T1 |--> T2)
| T_App:
    forall ctx t1 T11 T12 t2,
      ctx |- t1 \in (T11 |--> T12) ->
      ctx |- t2 \in T11 ->
      ctx |- App t1 t2 \in T12

where " ctx '|-' x '\in' t " := (has_type ctx x t).

Example type1:
  [("f"%string, (Bool |--> Bool))] |- App (Var 0) (If Fls Tru Fls) \in Bool.
Proof.
  eapply T_App. apply T_Var. reflexivity.
  apply T_If. apply T_False. apply T_True. apply T_False.
Qed.

Example type2:
  [("f"%string, (Bool |--> Bool))] |- (Abs "x" Bool (App (Var 1) (If (Var 0) Fls (Var 0)))) \in (Bool |--> Bool).
Proof.
  apply T_Abs. eapply T_App. apply T_Var. reflexivity.
  apply T_If. apply T_Var. reflexivity. apply T_False. apply T_Var. reflexivity.
Qed.

Lemma eqb_ty_eq : forall T1 T2,
    eqb_ty T1 T2 = true <-> T1 = T2.
Proof.
  split; intros.
  generalize dependent T2; induction T1; intros.
  destruct T2; auto. inversion H.
  inversion H. destruct T2. inversion H1. apply andb_prop in H1.
  inversion H1. apply IHT1_1 in H0. apply IHT1_2 in H2. rewrite H0, H2. reflexivity.

  generalize dependent T2; induction T1; intros.
  destruct T2. reflexivity. inversion H.

  destruct T2; auto. inversion H.
  simpl. inversion H. rewrite <- H1. rewrite <- H2. apply andb_true_intro.
  split; auto.
Qed.

Fixpoint typeof ctx t : option ty :=
  match t with
  | Tru =>
    (Some Bool)
  | Fls =>
    Some Bool
  | If t1 t2 t3 =>
    match typeof ctx t1 with
    | Some Bool =>
      match typeof ctx t2 with
      | Some T2 =>
        match typeof ctx t3 with
        | Some T3 =>
          if eqb_ty T2 T3 then
            Some T2
          else
            None
        | None => None
        end
      | None => None
      end
    | _ => None
    end
  | Var n =>
    getbinding n ctx
  | Abs x T1 t1 =>
    match typeof ((x, T1) :: ctx) t1 with
    | Some T2 =>
      Some (T1 |--> T2)
    | None => None
    end
  | App t1 t2 =>
    match typeof ctx t1 with
    | Some (T11 |--> T12) =>
      match typeof ctx t2 with
      | Some T21 =>
        if eqb_ty T11 T21 then
          Some T12
        else
          None
      | None => None
      end
    | _ => None
    end
  end.

Lemma eq_type_refl : forall T,
    eqb_ty T T = true.
Proof.
  induction T; simpl; auto. rewrite IHT1, IHT2; auto.
Qed.

Lemma typeof_hasType : forall t ctx T,
    has_type ctx t T <-> typeof ctx t = Some T.
Proof.
  split; intros.
  -
    induction H; simpl; auto.
    +
      rewrite IHhas_type1, IHhas_type2, IHhas_type3. clear.
      rewrite eq_type_refl; reflexivity.
    +
      rewrite IHhas_type. reflexivity.
    +
      rewrite IHhas_type2, IHhas_type1. rewrite eq_type_refl; reflexivity.
  -
    generalize dependent T. generalize dependent ctx; induction t; intros; simpl; auto.
    +
      inversion H; subst; apply T_Var; simpl; auto.
    +
      inversion H; subst. destruct (typeof ((name, typ) :: ctx) t) eqn:IH. inversion H1; subst.
      apply IHt in IH. apply T_Abs. apply IH. inversion H1.
    +
      inversion H. destruct (typeof ctx t1) eqn:IH1. destruct (typeof ctx t2) eqn:IH2. apply IHt1 in IH1. apply IHt2 in IH2. destruct t. inversion H1. destruct (eqb_ty t3 t0) eqn:IH3. apply eqb_ty_eq in IH3. subst. inversion H1; subst. eapply T_App; eauto. inversion H1. destruct t. inversion H1. inversion H1. inversion H1.
    +
      inversion H. apply T_True.
    +
      inversion H. apply T_False.
    +
      inversion H. destruct (typeof ctx t1) eqn:IH1. destruct (typeof ctx t2) eqn:IH2. apply IHt1 in IH1. apply IHt2 in IH2. destruct (typeof ctx t3) eqn:IH3. apply IHt3 in IH3. destruct t.
      destruct (eqb_ty t0 t4) eqn:IH4. apply eqb_ty_eq in IH4. subst. inversion H1; subst. eapply T_If; eauto.
      inversion H1. inversion H1. destruct t; try solve_by_invert. destruct t; try solve_by_invert. inversion H1.
Qed.

Lemma leb_0_T : forall n,
    Nat.leb 0 n = true.
Proof.
  induction n; auto.
Qed.

Fixpoint in_free t n :=
  match t with
  | Var n1 =>
    if Nat.leb n n1 then
      true
    else
      false
  | Abs x T t1 =>
    in_free t1 (S n)
  | App t1 t2 =>
    in_free t1 n || in_free t2 n
  | Tru => false
  | Fls => false
  | If t1 t2 t3 =>
    in_free t1 n || in_free t2 n || in_free t3 n
  end.

Notation closed t := (in_free t 0 = false).

Lemma var_hastype_none : forall ctx,
    getbinding (length ctx) ctx = None.
Proof.
  induction ctx; auto.
Qed.

Lemma var_hastype_none_succ : forall n ctx,
    Nat.leb (length ctx) n = true ->
    getbinding n ctx = None.
Proof.
  induction n; intros; auto.
  destruct ctx; auto. simpl in H. inversion H.
  destruct ctx. simpl. reflexivity.
  simpl. apply IHn. apply Nat.leb_le. apply le_S_n. apply Nat.leb_le. apply H.
Qed.

Require Import Nat.
Lemma closed_hastype : forall t T ctx,
    ctx |- t \in T ->
    in_free t (length ctx) = false.
Proof.
  induction t; intros; simpl; inversion H; subst; auto.
  destruct leb eqn:IH; auto. rewrite var_hastype_none_succ in H2. inversion H2. apply IH.
  apply IHt in H5. simpl in H5. apply H5.
  apply IHt1 in H3. apply IHt2 in H5. rewrite H3, H5; reflexivity.
  apply IHt1 in H4. apply IHt2 in H6. apply IHt3 in H7. rewrite H4, H6, H7; reflexivity.
Qed.

Lemma cosed_type_nil : forall t T,
    [] |- t \in T ->
    closed t.
Proof.
  intros. apply closed_hastype in H. simpl in H. apply H.
Qed.

Lemma appGetbind : forall ctx ctx' n,
    getbinding (n + (length ctx)) (ctx ++ ctx') = getbinding n ctx'.
Proof.
  induction ctx; simpl; intros; auto.
  rewrite <- plus_n_O; reflexivity.
  rewrite <- plus_Snm_nSm. simpl. apply IHctx.
Qed.

Lemma length1_Some : forall n ctx ctx1 ctx2 T,
    n < length ctx ->
    getbinding n (ctx ++ ctx1) = Some T ->
    getbinding n (ctx ++ ctx2) = Some T.
Proof.
  induction n; simpl; intros. destruct ctx. inversion H. simpl. simpl in H0. apply H0.
  destruct ctx. inversion H. simpl. destruct ( (p :: ctx) ++ ctx1) eqn:IHH. inversion H0. inversion IHH; subst.
  eapply IHn in H0. apply H0. simpl in H. apply lt_S_n in H. apply H.
Qed.

(**)
Fixpoint shift (d k : nat) (t : term) : term :=
match t with
| Var x =>
  Var (if leb d x then x + k else x)
| Abs x T t' =>
  Abs x T (shift (S d) k t')
| App t1 t2 =>
  App (shift d k t1) (shift d k t2)
| Tru => Tru
| Fls => Fls
| If t1 t2 t3 =>
  If (shift d k t1) (shift d k t2) (shift d k t3)
end.

Fixpoint subst (d : nat) (s t: term) : term :=
match t with
| Var x =>
  if eqb d x then (*d == x*)
    shift 0 d s
  else if ltb d x then (*d < x*)
         Var (pred x) else
         Var x (*d > x*)
| Abs x T t' => Abs x T (subst (S d) s t')
| App t1 t2 => App (subst d s t1) (subst d s t2)
| Tru => Tru
| Fls => Fls
| If t1 t2 t3 =>
  If (subst d s t1) (subst d s t2) (subst d s t3)
end.

Fixpoint eval (t: term) :=
  match t with
  | If t1 t2 t3 =>
    match t1 with
    | Tru => Some t2
    | Fls => Some t3
    | _ => match eval t1 with
          | Some t1' =>
            Some (If t1' t2 t3)
          | None => None
          end
    end
  | App t1 t2 =>
    if isval t1 then
      if isval t2 then
        match t1 with
        | Abs _ _ t12 => Some (subst 0 t2 t12)
        | _ => None
        end
      else
        match eval t2 with
        | Some t2' => Some (App t1 t2')
        | None => None
        end
    else
      match eval t1 with
      | Some t1' => Some (App t1' t2)
      | None => None
      end
  | _ => None
  end.

Compute (shift 0 1 (Abs _ _ (Var 1))).
Compute (subst 0 (App (Var 1) (Abs _ _ (Var 2))) (shift 1 1 (App (Var 0) (Abs _ _ (Var 1))))).
Compute (eval (App (Abs _ _ (App (Var 1) (App (Var 0) (Var 2)))) (Abs _ _ (Var 0)))).

(* (λ x. x)  λ y. y => λ y. y *)
Compute (eval (App (Abs "x" _ (Var 0)) (Abs "y" _ (Var 0)))).
(* TmAbs("y", TmVar(0, 1)) *)

(* (λ x. λ y. x) λ z. z => λ y. λ z. z *)
Compute (eval (App (Abs "x" _ (Abs "y" _ (Var 1))) (Abs "z" _ (Var 0)))).
 (* TmAbs("y", TmAbs("z", TmVar(0, 2))) *)

(* (λ x. λ x'. x) (λ x. x) => λ x'. λ x. x *)
Compute (eval (App (Abs "x" _ (Abs "x" _ (Var 1))) (Abs "x" _ (Var 0)))).
 (* TmAbs("x", TmAbs("x", TmVar(0, 2))) *)

(* (λ x. λ y. x) (λ z. z) (λ w. w) => (λ y. λ z. z) (λ w. w) *)
Compute (eval (App (App (Abs "x" _ (Abs "y" _ (Var 1))) (Abs "z" _ (Var 0))) (Abs "w" _ (Var 0)))).
(* TmApp(TmAbs("y", TmAbs("z", TmVar(0, 2))), TmAbs("w", TmVar(0, 1))) *)

(* (λ x. x) ((λ y. y) (λ z. z))  => (λ x. x) (λ z. z) *)
Compute (eval (App (Abs "x" _ (Var 0)) (App (Abs "y" _ (Var 0)) (Abs "z" _ (Var 0))))).
(* TmApp(TmAbs("x", TmVar(0, 1)), TmAbs("z", TmVar(0, 1))) *)

(* (λ x. x x) (λ x. x x) => (λ x. x x) (λ x. x x) *)
Compute (eval (App (Abs "x" _ (App (Var 0) (Var 0))) (Abs "x" _ (App (Var 0) (Var 0))))).
 (* TmApp(TmAbs("x", TmApp(TmVar(0, 1), TmVar(0, 1))), TmAbs("x", TmApp(TmVar(0, 1), TmVar(0, 1))) *)

Reserved Notation " t '-->' t' " (at level 40).
Inductive step :term -> term -> Prop :=
| E_IfTrue : forall t2 t3,
    If Tru t2 t3 --> t2
| E_IfFalse : forall t2 t3,
    If Fls t2 t3 --> t3
| E_If : forall t1 t1' t2 t3,
    t1 --> t1' ->
    If t1 t2 t3 --> If t1' t2 t3
| E_App1 : forall t1 t2 t1',
    t1 --> t1' ->
    App t1 t2 --> App t1' t2
| E_App2 : forall v1 t2 t2',
    value v1 ->
    t2 --> t2' ->
    App v1 t2 --> App v1 t2'
| E_AppAbs : forall typ str t12 t2,
    value t2 ->
    App (Abs typ str t12) t2 --> subst 0 t2 t12

  where " t '-->' t' " := (step t t').

Lemma shift0 : forall t n,
    shift n 0 t = t.
Proof.
  induction t; intros; simpl; eauto.
  rewrite <- plus_n_O. destruct leb; reflexivity.

  rewrite IHt; reflexivity.
  rewrite IHt1, IHt2; reflexivity.
  rewrite IHt1, IHt2, IHt3; reflexivity.
Qed.

Lemma shifting : forall t g g1 g2 T,
  (g1 ++ g) |- t \in T ->
  (g1 ++ g2 ++ g) |- (shift (length g1) (length g2) t) \in T.
Proof.
  induction t; intros; inversion H; subst; clear H; try solve [econstructor; eauto]; simpl.

  apply T_Var. destruct (leb) eqn:IH. apply Nat.leb_le in IH.
  generalize dependent g. generalize dependent T. generalize dependent n.
  induction g1; simpl; intros; eauto. rewrite appGetbind. apply H2.
  destruct n. inversion IH. simpl.
  apply le_S_n in IH. simpl in H2. eapply IHg1 in IH; eauto.

  apply Nat.leb_gt in IH. eapply length1_Some in IH. apply IH. apply H2.

  apply T_Abs.
  assert (S (length g1) = length ((name, typ) :: g1)). reflexivity.
  rewrite H. apply IHt with (g1:= ((name, typ) :: g1)). apply H5.
Qed.

Lemma gb_lt_add : forall ctx ctx' p T n,
  getbinding (S n) (ctx' ++ p :: ctx) = Some T ->
  length ctx' < S n ->
  getbinding n (ctx' ++ ctx) = Some T.
Proof.
  induction ctx'; simpl; intros; eauto.
  destruct n. inversion H0; subst. apply Nat.leb_le in H2; inversion H2.
  apply IHctx' in H. simpl. apply H. apply lt_S_n. apply H0.
Qed.

Lemma L9_3_8: forall t s x Ts T ctx ctx',
    (ctx' ++ (x, Ts) :: ctx) |- t \in T ->
    ctx |- s \in Ts ->
    (ctx' ++ ctx) |- subst (length ctx') s t \in T.
Proof.
  induction t; intros; inversion H; subst; clear H; try solve [econstructor; eauto]; simpl.
  destruct eqb eqn:IHeq.
  apply Nat.eqb_eq in IHeq; subst. apply shifting with (g2 := ctx') (g1:= []) in H0; simpl in H0.
  rewrite <- (plus_O_n (length ctx')) in H3. rewrite (appGetbind ctx' ( (x, Ts) :: ctx) 0) in H3.
  simpl in H3. inversion H3; subst. apply H0.
  destruct ltb eqn:IHlt. apply Nat.ltb_lt in IHlt.
  destruct n. inversion IHlt. simpl. apply T_Var. clear H0.
  eapply gb_lt_add in H3; eauto.

  apply Nat.ltb_ge in IHlt. apply T_Var.
  apply le_lt_or_eq in IHlt. destruct IHlt.
  eapply length1_Some in H; eauto.
  subst. rewrite Nat.eqb_refl in IHeq; inversion IHeq.

  apply T_Abs. apply (IHt s x Ts T2 ctx ((name, typ) :: ctx')) in H6. simpl in H6. apply H6.
  apply H0.
Qed.

Theorem T9_3_9 : forall t t' T ctx,
    ctx |- t \in T ->
    t --> t' ->
    ctx |- t' \in T.
Proof.
  intros. generalize dependent T. induction H0; subst; simpl; intros; try solve [inversion H; subst; eauto].
  -
    inversion H; subst. apply IHstep in H5. apply T_If; auto.
  -
    inversion H; subst. apply IHstep in H4. apply T_App with T11; auto.
  -
    inversion H1; subst. apply IHstep in H7. apply T_App with T11; auto.
  -
    inversion H0; subst. clear H0. inversion H4; subst.
    apply (L9_3_8 t12 t2 typ T11 T ctx []) in H2; eauto.
Qed.

Extraction "./ocaml/deBruijin/src/eval" typeof eval.

Compute (subst 0 (Var 1) (shift 1 1 (App (Var 0) (Abs _ _ (Abs _ _ (Var 2)))))).
Compute (subst 0 (App (Var 1) (Abs _ _ (Var 2))) (shift 1 1 (App (Var 0) (Abs _ _ (Var 1))))).
Compute (subst 0 (Var 1) (shift 1 1 (Abs _ _ (App (Var 0) (Var 2))))).
Compute (subst 0 (Var 1) (shift 1 1 (Abs _ _  (App (Var 1) (Var 0))))).


Require Import LibTactics.
Require Import Coq.Wellfounded.Inverse_Image.
Require Import MyTactics.

Require Export Autosubst.Autosubst.
Require Export AutosubstExtra.
Require Export Autosubst_IsRen.

(* Require Export Autosubst_EOS. *)
Require Export Autosubst_FreeVars.

(* The syntax of the lambda-calculus. *)

Inductive term :=
| Var (x : var)
| Lam (t : {bind term})
| App (t1 t2 : term)
| Let (t1 : term) (t2 : {bind term})
| Default (ts: list term) (tj tc: term)
| Empty
| Conflict
| Const (b: bool)
.

Lemma term_ind':
forall P : term -> Prop,
(forall x : var, P (Var x)) ->
(forall t : {bind term}, P t -> P (Lam t)) ->
(forall t1 : term, P t1 -> forall t2 : term, P t2 -> P (App t1 t2)) ->
(forall t1 : term,
 P t1 -> forall t2 : {bind term}, P t2 -> P (Let t1 t2)) ->
(forall (ts : list term),
 List.Forall (fun ti => P ti) ts -> forall tj : term,
 P tj -> forall tc : term, P tc -> P (Default ts tj tc)) ->
P Empty -> P Conflict -> (forall b, P (Const b)) -> forall t : term, P t.
Proof.
  intros; gen t.
  fix IH 1.
  intros t; case t.
  * apply H.
  * intros; apply H0; apply IH.
  * intros; apply H1; apply IH.
  * intros; apply H2; apply IH.
  * intros; apply H3; try apply IH.
    { induction ts; econstructor.
      apply IH.
      apply IHts.
    }
  * apply H4.
  * apply H5.
  * apply H6.
Qed.
(*
(* 2022-05-03 TODO: ajouter des égalités et fonction de comparaison (comme en ocaml) *)
Definition term_eq: term -> term -> bool.
Admitted.

Definition term_eq_OK t1 t2: reflect (t1 = t2) (term eq t1 t2).

*)

Global Instance Ids_term : Ids term. derive. Defined.
Global Instance Rename_term : Rename term. derive. Defined.
Global Instance Subst_term : Subst term. derive. Defined.
Global Instance SubstLemmas_term : SubstLemmas term. derive. Qed.
Global Instance IdsLemmas_term : IdsLemmas term.
Proof. econstructor. intros. injections. eauto. Qed.

(* If the image of [t] through a substitution is a variable, then [t] must
   itself be a variable. *)

Lemma subst_is_var:
  forall t sigma x,
  t.[sigma] = ids x ->
  exists y,
  t = ids y.
Proof.
  intros ? ? ? Heq. destruct t; compute in Heq; solve [ eauto | congruence ].
Qed.

(* The identity substitution [ids] is injective. *)

Lemma inj_ids:
  forall x y,
  ids x = ids y ->
  x = y.
Proof.
  intros ? ? Heq. compute in Heq. congruence.
Qed.

(* If the composition of two substitutions [sigma1] and [sigma2] is the
   identity substitution, then [sigma1] must be a renaming. *)

Lemma ids_implies_is_ren:
  forall sigma1 sigma2,
  sigma1 >> sigma2 = ids ->
  is_ren sigma1.
Proof.
  intros ? ? Hid.
  eapply prove_is_ren; [ eapply inj_ids | intros x ].
  eapply subst_is_var with (sigma := sigma2) (x := x).
  rewrite <- Hid. reflexivity.
Qed.

Global Hint Resolve ids_implies_is_ren : is_ren obvious.

(* The size of a term. *)

Definition list_size size := fix list_size (ts: list term) :=
  match ts with
  | nil => 1
  | cons h ts => size h + list_size ts
  end
.

Fixpoint size (t : term) : nat :=
  match t with
  | Var _ => 0
  | Lam t => 1 + size t
  | App t1 t2
  | Let t1 t2 => 1 + size t1 + size t2
  | Default ts tj tc =>
      1 + list_size size ts + size tj + size tc
  | Empty => 0
  | Conflict => 0
  | Const _ => 0
  end.

(* The [size] function imposes a well-founded ordering on terms. *)

Require Import PeanoNat.
Lemma smaller_wf:
  well_founded (fun t1 t2 => size t1 < size t2).
Proof.
  eauto using wf_inverse_image, lt_wf.
Qed.

(* The tactic [size_induction] facilitates proofs by induction on the
   size of a term. The following lemmas are used in the construction
   of this tactic. *)

Lemma size_induction_intro:
  forall (P : term -> Prop),
  (forall n t, size t < n -> P t) ->
  (forall t, P t).
Proof.
  eauto. (* just instantiate [n] with [size t + 1] *)
Defined.

Lemma size_induction_induction:
  forall (P : term -> Prop),
  (forall n, (forall t, size t < n -> P t) -> (forall t, size t < S n -> P t)) ->
  (forall n t, size t < n -> P t).
Proof.
  intros P IH. induction n; intros.
  { false. eapply Nat.nlt_0_r. eauto. }
  { eauto. }
Defined.

Lemma size_induction:
  forall (P : term -> Prop),
  (forall n, (forall t, size t < n -> P t) -> (forall t, size t < S n -> P t)) ->
  (forall t, P t).
Proof.
  intros P IH.
  eapply size_induction_intro.
  eapply size_induction_induction.
  eauto.
Defined.

Ltac size_induction t :=
  (* We assume the goal is of the form [forall t, P t]. *)
  intro t; pattern t;
  match goal with |- ?P t =>
    simpl; eapply (@size_induction P); clear
  end;
  intros n IH t Htn.
  (* The goal should now be of the form [P t]
     with a hypothesis [IH: (forall t, size t < n -> P t]
     and a hypothesis [Htn: size t < S n]. *)

(* The size of a term is preserved by renaming. *)

Lemma size_renaming:
  forall t sigma,
  is_ren sigma ->
  size t.[sigma] = size t.
Proof.
  induction t using term_ind'; intros sigma Hsigma; asimpl;
  repeat (match goal with h: forall sigma, _ |- _ => rewrite h by obvious; clear h end);
  try reflexivity.
  (* [Var] *)
  { destruct Hsigma as [ xi ? ]. subst. reflexivity. }
  (* [Default] *)
  { do 3 fequal.
    induction ts; unfold list_size; simpl; inverts H; eauto.
  }
Qed.

(* The tactic [size] proves goals of the form [size t < n]. The tactic
   [obvious] is also extended to prove such goals. *)

Global Hint Extern 1 (size ?t.[?sigma] < ?n) =>
  rewrite size_renaming by obvious
  : size obvious.

Global Hint Extern 1 (size ?t < ?n) =>
  simpl in *; lia
  : size obvious.

Ltac size :=
  eauto with size.

(* The following is a direct proof of [smaller_wf]. We do not use any
   preexisting lemmas, and end the proof with [Defined] instead of [Qed],
   so as to make the proof term transparent. Also, we avoid the tactic
   [lia], which produces huge proof terms. This allows Coq to compute
   with functions that are defined by well-founded recursion. *)

Lemma smaller_wf_transparent:
  well_founded (fun t1 t2 => size t1 < size t2).
Proof.
  unfold well_founded. size_induction t.
  constructor; intros u Hu.
  eapply IH. eapply lt_S_n. eapply le_lt_trans; eauto.
Defined.

(* The following lemmas can be useful in situations where the tactic
   [asimpl] performs too much simplification. *)

Lemma subst_var:
  forall x sigma,
  (Var x).[sigma] = sigma x.
Proof.
  autosubst.
Qed.

Lemma subst_lam:
  forall t sigma,
  (Lam t).[sigma] = Lam (t.[up sigma]).
Proof.
  autosubst.
Qed.

Lemma subst_app:
  forall t1 t2 sigma,
  (App t1 t2).[sigma] = App t1.[sigma] t2.[sigma].
Proof.
  autosubst.
Qed.

Lemma subst_let:
  forall t1 t2 sigma,
  (Let t1 t2).[sigma] = Let t1.[sigma] t2.[up sigma].
Proof.
  autosubst.
Qed.

Lemma subst_default:
  forall ts tj tc sigma,
  (Default ts tj tc).[sigma] = Default ts..[sigma] tj.[sigma] tc.[sigma].
Proof.
  autosubst.
Qed.

Lemma subst_empty:
  forall sigma,
  (Empty).[sigma] = Empty.
Proof.
  autosubst.
Qed.

Lemma subst_conflict:
  forall sigma,
  (Conflict).[sigma] = Conflict.
Proof.
  autosubst.
Qed.

Lemma subst_const:
  forall b sigma,
  (Const b).[sigma] = Const b.
Proof.
  autosubst.
Qed.


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

Require Import PeanoNat tools algebra Bool bindings types_of_bsp.

Section s.
  Context {X : Set}.

  Inductive sp_terms {X : Set} : Set :=
    | sp_seq : sp_terms -> sp_terms -> sp_terms
    | sp_par : sp_terms -> sp_terms -> sp_terms
    | sp_var : X -> sp_terms
    | sp_unit : sp_terms.

  Global Instance sp_seq_prod : Product (@sp_terms X) := sp_seq.

  Global Instance sp_par_prod : ParProduct (@sp_terms X) := sp_par.

  Global Instance sp_unit_unit : Un (@sp_terms X) := sp_unit.

  Global Instance sp_size : Size (@sp_terms X) :=
    fix sp_size s :=
    match s with
    | sp_par s1 s2 | sp_seq s1 s2 => sp_size s1 + sp_size s2
    | sp_unit => 0
    | sp_var _ => 1
    end.

  Remark sp_unit_un : sp_unit = @un sp_terms _.
  Proof. reflexivity. Qed.
  Remark sp_size_un : ⎢𝟭⎥ = 0.
  Proof. reflexivity. Qed.
  Remark sp_size_var x : ⎢sp_var x⎥ = 1.
  Proof. reflexivity. Qed.
  Remark sp_prod_prod s t: sp_seq s t= (@prod sp_terms _ s t).
  Proof. reflexivity. Qed.
  Remark sp_size_prod s t : ⎢s⋅t⎥ = ⎢s⎥+⎢t⎥.
  Proof. reflexivity. Qed.
  Remark sp_par_par s t : sp_par s t = (@par sp_terms _ s t).
  Proof. reflexivity. Qed.
  Remark sp_size_par s t : ⎢s∥t⎥ = ⎢s⎥+⎢t⎥.
  Proof. reflexivity. Qed.

  Hint Rewrite sp_unit_un sp_size_un sp_size_var sp_prod_prod sp_size_prod sp_par_par sp_size_par : simpl_typeclasses.

  Inductive sp_eq : Equiv sp_terms :=
  | sp_eq_refl s : s ≡ s
  | sp_eq_sym s t : s ≡ t -> t ≡ s
  | sp_eq_trans s t u : s ≡ t -> t ≡ u -> s ≡ u
  | sp_eq_seq s t s' t' : s ≡ t -> s' ≡ t' -> s ⋅ s' ≡ t ⋅ t'
  | sp_eq_par s t s' t' : s ≡ t -> s' ≡ t' -> s ∥ s' ≡ t ∥ t'
  | sp_eq_seq_ass s t u : s ⋅ (t ⋅ u) ≡ (s ⋅ t) ⋅ u
  | sp_eq_par_ass s t u : s ∥ (t ∥ u) ≡ (s ∥ t) ∥ u
  | sp_eq_par_comm s t : s ∥ t ≡ t ∥ s
  | sp_eq_seq_left_unit s : 𝟭 ⋅ s ≡ s
  | sp_eq_seq_right_unit s : s ⋅ 𝟭 ≡ s
  | sp_eq_par_unit s : 𝟭 ∥ s ≡ s.
  Hint Constructors sp_eq.
  Global Instance sp_eq_Equiv : Equiv sp_terms := sp_eq.

  Global Instance sp_eq_Equivalence : Equivalence equiv.
  Proof. split;intro;intros;eauto. Qed.

  Global Instance sp_terms_bimonoid : BiMonoid sp_terms equiv prod par un.
  Proof. repeat split;repeat intro;eauto. Qed.

  Lemma sp_size_proper : Proper (equiv ==> Logic.eq) size.
  Proof. intros s t E;induction E;rsimpl;lia. Qed.

  Lemma sp_size_unit s : ⎢s⎥ = 0 <-> s ≡ 𝟭.
  Proof.
    split.
    - induction s;rsimpl.
      + intro;rewrite IHs1,IHs2;auto||lia.
      + intro;rewrite IHs1,IHs2;auto||lia.
      + discriminate.
      + reflexivity.
    - intros E;apply sp_size_proper in E as ->;reflexivity.
  Qed.
  Fixpoint sp_clean s :=
    match s with
    | sp_par s1 s2 =>
      match sp_clean s1,sp_clean s2 with
      | sp_unit,s' | s',sp_unit => s'
      | s'1,s'2 => s'1∥s'2
      end
    | sp_seq s1 s2 =>
      match sp_clean s1,sp_clean s2 with
      | sp_unit,s' | s',sp_unit => s'
      | s'1,s'2 => s'1⋅s'2
      end
    | s => s
    end.

  Lemma sp_clean_eq s : s ≡ sp_clean s.
  Proof.
    induction s;simpl.
    - destruct (sp_clean s1),(sp_clean s2);rewrite IHs1,IHs2;auto;
        rewrite left_unit||rewrite right_unit;reflexivity.
    - destruct (sp_clean s1),(sp_clean s2);rewrite IHs1,IHs2;auto;
        rewrite left_unit||rewrite right_unit;reflexivity.
    - reflexivity.
    - reflexivity.
  Qed.

  Fixpoint is_sp_clean (s : @sp_terms X) :=
    match s with
    | sp_par s1 s2 | sp_seq s1 s2 => is_sp_clean s1 /\ is_sp_clean s2
    | sp_var _ => True
    | _ => False
    end.

  Lemma sp_clean_idem s : is_sp_clean s -> sp_clean s = s.
  Proof.
    induction s;simpl.
    - intros (C1&C2).
      rewrite (IHs1 C1) in *;rewrite (IHs2 C2) in *.
      destruct s1,s2;simpl in *;reflexivity||tauto.
    - intros (C1&C2).
      rewrite (IHs1 C1) in *;rewrite (IHs2 C2) in *.
      destruct s1,s2;simpl in *;reflexivity||tauto.
    - reflexivity.
    - tauto.
  Qed.

  Lemma sp_clean_is_sp_clean s : sp_clean s = 𝟭 \/ is_sp_clean (sp_clean s).
  Proof.
    induction s.
    - simpl;destruct IHs1 as [->|I1],IHs2 as [->|I2];simpl;auto.
      + destruct (sp_clean s1);simpl in *;auto.
      + destruct (sp_clean s1),(sp_clean s2);simpl in *;auto.
    - simpl;destruct IHs1 as [->|I1],IHs2 as [->|I2];simpl;auto.
      + destruct (sp_clean s1);simpl in *;auto.
      + destruct (sp_clean s1),(sp_clean s2);simpl in *;auto.
    - right;simpl;auto.
    - left;reflexivity.
  Qed.

  Lemma is_sp_clean_sp_size s : is_sp_clean s -> 0 < ⎢s⎥.
  Proof. induction s;rsimpl;firstorder lia. Qed.

  Definition sp_type t :=
    match sp_clean t with
    | sp_var _ => VarT
    | sp_seq _ _ => SeqT
    | sp_par _ _ => ParT
    | sp_unit => UnT
    end.

  Lemma sp_type_clean_proper : Proper (equiv ==> Logic.eq) (fun s => sp_type s).
  Proof.
    intros s t E;induction E;simpl;auto.
    - etransitivity;eassumption.
    - unfold sp_type in *;simpl in *;
        destruct (sp_clean s),(sp_clean t);simpl in *;try discriminate;
          destruct (sp_clean s'),(sp_clean t');simpl in *;discriminate||reflexivity.
    - unfold sp_type in *;simpl in *;
        destruct (sp_clean s),(sp_clean t);simpl in *;try discriminate;
          destruct (sp_clean s'),(sp_clean t');simpl in *;discriminate||reflexivity.
    - unfold sp_type in *;simpl in *;
        destruct (sp_clean s),(sp_clean t),(sp_clean u);simpl in *;discriminate||reflexivity.
    - unfold sp_type in *;simpl in *;
        destruct (sp_clean s),(sp_clean t),(sp_clean u);simpl in *;discriminate||reflexivity.
    - unfold sp_type in *;simpl in *;
        destruct (sp_clean s),(sp_clean t);simpl in *;discriminate||reflexivity.
    - unfold sp_type in *;simpl in *;
        destruct (sp_clean s);simpl in *;discriminate||reflexivity.
  Qed.

  Lemma sp_size_Π L : ⎢Π L⎥ = sum size L.
  Proof. induction L;rsimpl;auto. Qed.

  Fixpoint subterms (s : @sp_terms X) :=
    match s with
    | sp_par s1 s2 | sp_seq s1 s2 => s::subterms s1 ++ subterms s2
    | s => [s]
    end.

  Context {dec: decidable_set X}.
  Global Instance dec_sp_terms : decidable_set (@sp_terms X).
  Proof.
    set (sp_eqX := fix f s t := match s,t with
                             | sp_unit,sp_unit => true
                             | sp_var x,sp_var y => x =?= y
                             | sp_seq s1 s2,sp_seq t1 t2
                             | sp_par s1 s2,sp_par t1 t2 => f s1 t1 && f s2 t2
                             | _,_ => false
                             end).
    apply (@Build_decidable_set sp_terms sp_eqX).
    intros s t;apply iff_reflect.
    revert t;induction s as [s1 ? s2|s1 ? s2|x|];intros [t1 t2|t1 t2|y|];simpl;
      repeat rewrite andb_true_iff;try rewrite <-IHs1,<-IHs2;
        firstorder (try discriminate||inversion H;subst;auto).
    - apply eqX_correct;reflexivity.
    - rewrite eqX_correct in H;subst;reflexivity.
  Qed.

  Axiom sp_eq_dec : forall s t, {s ≡ t} + {~ (s ≡ t)}.

End s.
Arguments sp_terms : clear implicits.
Hint Constructors sp_eq.
Hint Rewrite @sp_size_un @sp_size_var @sp_prod_prod @sp_size_prod @sp_par_par @sp_size_par : simpl_typeclasses.


From Tealeaves Require Import
  Classes.Setlike.Functor
  LN.Atom.

From Coq Require
  MSets.MSets.

Import List.ListNotations.
Import Setlike.Functor.Notations.

(** * Definition of <<AtomSet>> type *)
(******************************************************************************)
Module AtomSet <: Coq.MSets.MSetInterface.WSets :=
  Coq.MSets.MSetWeakList.Make Atom.

Module AtomSetProperties :=
  Coq.MSets.MSetProperties.WPropertiesOn Atom AtomSet.

(** ** Notations for operations on <<AtomSet>> *)
(******************************************************************************)
Declare Scope set_scope.
Delimit Scope set_scope with set.
Open Scope set_scope.

Module Notations.

  Notation "x ∈@ S" := (AtomSet.In x S) (at level 40) : set_scope.
  Notation "s [=] t" := (AtomSet.Equal s t) (at level 70, no associativity) : set_scope.
  Notation "s ⊆ t" := (AtomSet.Subset s t) (at level 70, no associativity) : set_scope.
  Notation "s ∩ t" := (AtomSet.inter s t) (at level 60, no associativity) : set_scope.
  Notation "s \\ t" := (AtomSet.diff s t) (at level 60, no associativity) : set_scope.
  Notation "s ∪ t" := (AtomSet.union s t) (at level 61, left associativity) : set_scope.
  Notation "'elements'" := (AtomSet.elements) (at level 60, no associativity) : set_scope.
  Notation "∅" := (AtomSet.empty) : set_scope.
  Notation "{{ x }}" := (AtomSet.singleton x) : set_scope.

  Tactic Notation "fsetdec" := AtomSetProperties.Dec.fsetdec.

End Notations.

Import Notations.

(** ** The [atoms] operation *)
(** <<atoms>> collects a list of atoms into an <<AtomSet>>. It is
    conceptually inverse to [AtomSet.elements], but there's no
    guarantee the operations won't disturb the order*)
(******************************************************************************)
Fixpoint atoms (l : list atom) : AtomSet.t :=
  match l with
  | nil => ∅
  | x :: xs => AtomSet.add x (atoms xs)
  end.

(** ** Rewriting rules *)
(******************************************************************************)
Create HintDb tea_rw_atoms.

Lemma atoms_nil : atoms nil = ∅.
Proof.
  reflexivity.
Qed.

Lemma atoms_cons : forall (x : atom) (xs : list atom),
    atoms (x :: xs) [=] {{ x }} ∪ atoms xs.
Proof.
  intros. cbn. fsetdec.
Qed.

Lemma atoms_one : forall (x : atom),
    atoms [x] [=] {{ x }}.
Proof.
  intros. cbn. fsetdec.
Qed.

Lemma atoms_app : forall (l1 l2 : list atom),
    atoms (l1 ++ l2) [=] atoms l1 ∪ atoms l2.
Proof.
  induction l1.
  - cbn. List.simpl_list. fsetdec.
  - cbn. introv. rewrite (IHl1 l2). fsetdec.
Qed.

#[export] Hint Rewrite atoms_nil atoms_cons atoms_one atoms_app : tea_rw_atoms.

Lemma in_atoms_nil : forall x, x ∈@ atoms nil <-> False.
Proof.
  cbn. fsetdec.
Qed.

Lemma in_atoms_cons : forall (y : atom) (x : atom) (xs : list atom),
    y ∈@ atoms (x :: xs) <-> y = x \/ y ∈@ atoms xs.
Proof.
   intros. autorewrite with tea_rw_atoms. fsetdec.
Qed.

Lemma in_atoms_one : forall (y x : atom),
    y ∈@ atoms [x] <-> y = x.
Proof.
  intros. autorewrite with tea_rw_atoms. fsetdec.
Qed.

Lemma in_atoms_app : forall (x : atom) (l1 l2 : list atom),
    x ∈@ atoms (l1 ++ l2) <-> x ∈@ atoms l1 \/ x ∈@ atoms l2.
Proof.
   intros. autorewrite with tea_rw_atoms. fsetdec.
Qed.

#[export] Hint Rewrite in_atoms_nil in_atoms_cons in_atoms_one in_atoms_app : tea_rw_atoms.

Lemma in_singleton_iff : forall (x : atom) (y : atom),
    y ∈@ {{ x }} <-> y = x.
Proof.
  intros. fsetdec.
Qed.

Lemma in_union_iff : forall (x : atom) (s1 s2 : AtomSet.t),
    x ∈@ (s1 ∪ s2) <-> x ∈@ s1 \/ x ∈@ s2.
Proof.
  intros. fsetdec.
Qed.

(** ** Relating <<AtomSet.t>> and <<list atom>> *)
(******************************************************************************)
Lemma in_elements_iff : forall (s : AtomSet.t) (x : atom),
    x ∈@ s <-> x ∈ elements s.
Proof.
  intros. rewrite <- AtomSet.elements_spec1. induction (elements s).
  - cbv. split; intro H; inversion H.
  - cbn. split; intro H; inversion H.
    + subst. now left.
    + subst. destruct H.
      subst. rewrite IHl in H1. now right.
      rewrite IHl in H1. now right.
    + subst. now left.
    + right. now rewrite IHl.
Qed.

Lemma in_atoms_iff : forall (l : list atom) (x : atom), x ∈ l <-> x ∈@ atoms l.
Proof.
  intros. induction l.
  - easy.
  - autorewrite with tea_rw_atoms tea_list.
    now rewrite IHl.
Qed.