Require Import Ensembles.
Require Import Coq.Lists.List.

Require Import ListExt.
Require Import folProof.
Require Import folProp.
Require Import Deduction.

Section Logic_Rules.

Variable L : Language.
Let Formula := Formula L.
Let Formulas := Formulas L.
Let System := System L.
Let Term := Term L.
Let Terms := Terms L.
Let Prf := Prf L.
Let SysPrf := SysPrf L.

Lemma Axm T f: mem _ T f -> SysPrf T f.
Proof.
  exists (f :: nil); exists (AXM L f).
  intros g [H0 | H0].
  - rewrite H0 in H; assumption.
  - elim H0.
Qed.

Lemma sysExtend  (T U : System) (f : Formula):
 Included _ T U -> SysPrf T f -> SysPrf U f.
Proof.
  intros H [x [p H0]]; exists x, p.
  intros g H1.
  apply H, H0, H1.
Qed.

Lemma sysWeaken  (T : System) (f g : Formula):
  SysPrf T f -> SysPrf (Ensembles.Add _ T g) f.
Proof.
  intros H; apply sysExtend with T.
  - unfold Included in |- *.
    intros f0 Hf0;  now left.
  - assumption.
Qed.

Lemma impI (T : System) (f g : Formula):
 SysPrf (Ensembles.Add _ T g) f -> SysPrf T (impH g f).
Proof. intros ?; now apply (DeductionTheorem L). Qed.

Lemma impE (T : System) (f g : Formula):
 SysPrf T (impH g f) -> SysPrf T g -> SysPrf T f.
Proof.
  intros (x, (px, Hx)) (x1, (px1, Hx1)).
  set (A1 := MP L _ _ _ _ px px1) in *.
  exists (x ++ x1), A1.
  intros g0 H; case (in_app_or _ _ _ H); auto.
Qed.

Lemma contradiction (T : System) (f g : Formula):
 SysPrf T f -> SysPrf T (notH f) -> SysPrf T g.
Proof.
  intros H H0; eapply impE with f.
  - eapply impE with (impH (notH g) (notH f)).
    + exists (nil (A:=Formula)).
      exists (CP L g f).
      contradiction.
    + apply impI; apply sysWeaken.
      assumption.
  - assumption.
Qed.

Lemma nnE (T : System) (f : Formula):
  SysPrf T (notH (notH f)) -> SysPrf T f.
Proof.
  intros H; apply impE with (notH (notH f)).
  - apply impE with (impH (notH f) (notH (notH (notH f)))).
    + exists (nil (A:=Formula)).
      exists (CP L f (notH (notH f))).
      contradiction.
    + apply impI.
      apply contradiction with (notH f).
      apply Axm.
      right; constructor.
      apply sysWeaken; assumption.
  - assumption.
Qed.

Lemma noMiddle  (T : System) (f : Formula):
  SysPrf T (orH (notH f) f).
Proof.
  unfold orH in |- *.
  apply impI, nnE, Axm; right; constructor.
Qed.

Lemma nnI (T : System) (f : Formula):
  SysPrf T f -> SysPrf T (notH (notH f)).
Proof.
  intros H; apply impE with f; [ | apply H].
  apply impE with (impH (notH (notH (notH f))) (notH f)).
  - exists (nil (A:=Formula)).
    exists (CP L (notH (notH f)) f); contradiction.
  - apply impI; apply contradiction with f.
    + apply sysWeaken; assumption.
    + apply nnE, Axm; right; constructor.
Qed.

(* contraposition *)
Lemma cp1 (T : System) (f g : Formula) :
 SysPrf T (impH (notH f) (notH g)) -> SysPrf T (impH g f).
Proof.
  intros H; apply impE with (impH (notH f) (notH g)).
  - exists (nil (A:=Formula)).
    exists (CP L f g); contradiction.
  - assumption.
Qed.

Lemma cp2 (T : System) (f g : Formula):
 SysPrf T (impH g f) -> SysPrf T (impH (notH f) (notH g)).
Proof.
  intros H.
  apply impE with (impH (notH (notH g)) (notH (notH f))).
  - exists (nil (A:=Formula)).
    exists (CP L (notH g) (notH f)); contradiction.
  - apply impI, nnI.
    apply impE with g.
    + apply sysWeaken; assumption.
    + apply nnE, Axm; right; constructor.
Qed.

Lemma orI1 (T : System) (f g : Formula):
  SysPrf T f -> SysPrf T (orH f g).
Proof.
  intros H; unfold orH in |- *.
  apply impI.
  apply contradiction with f.
  apply sysWeaken; assumption.
  apply Axm; right; constructor.
Qed.

Lemma orI2 (T : System) (f g : Formula):
  SysPrf T g -> SysPrf T (orH f g).
Proof.
  intros h; unfold orH in |- *.
  apply impI, sysWeaken; assumption.
Qed.

Lemma orE (T : System) (f g h : Formula):
 SysPrf T (orH f g) ->
 SysPrf T (impH f h) -> SysPrf T (impH g h) -> SysPrf T h.
Proof.
  intros H H0 H1; unfold orH in H.
  apply impE with (impH h h).
  - apply cp1.
    apply impE with (impH (notH h) h).
    + apply impI.
      apply impI.
      apply contradiction with h.
      apply impE with (notH h).
      apply Axm; left; right; constructor.
      apply Axm; right; constructor.
      apply Axm; right; constructor.
    + apply impI.
      apply impE with g.
      apply sysWeaken; assumption.
      apply impE with (notH f).
      apply sysWeaken; assumption.
      apply impE with (notH h).
      * apply cp2.
        apply sysWeaken; assumption.
      * apply Axm; right; constructor.
  - apply impI, Axm; right; constructor.
Qed.

Lemma orSys (T : System) (f g h : Formula):
 SysPrf (Ensembles.Add _ T f) h -> SysPrf (Ensembles.Add _ T g) h ->
 SysPrf (Ensembles.Add _ T (orH f g)) h.
Proof.
  intros H H0; eapply orE.
   - apply Axm; right; constructor.
   - apply sysWeaken, impI; assumption.
   - apply sysWeaken, impI; assumption.
Qed.

Lemma andI (T : System) (f g : Formula):
 SysPrf T f -> SysPrf T g -> SysPrf T (andH f g).
Proof.
  intros H H0; unfold andH in |- *.
  apply orE with (notH (orH (notH f) (notH g))) (orH (notH f) (notH g)).
  - apply noMiddle.
  - apply impI, Axm; right; constructor.
  - apply impI; apply orE with (notH f) (notH g).
    + apply Axm; right; constructor.
    + apply cp2; apply impI.
      repeat apply sysWeaken; assumption.
    + apply cp2; apply impI.
      repeat apply sysWeaken; assumption.
Qed.

Lemma andE1 (T : System) (f g : Formula):
  SysPrf T (andH f g) -> SysPrf T f.
Proof.
  intros H; apply nnE.
  apply impE with (andH f g).
  unfold andH in |- *; apply cp2.
  apply impI, orI1.
  apply Axm; right; constructor.
  assumption.
Qed.

Lemma andE2  (T : System) (f g : Formula):
  SysPrf T (andH f g) -> SysPrf T g.
Proof.
  intros H; apply nnE.
  apply impE with (andH f g).
  - apply cp2, impI, orI2, Axm; right; constructor.
  - assumption.
Qed.

Lemma iffI  (T : System) (f g : Formula) :
 SysPrf T (impH f g) -> SysPrf T (impH g f) -> SysPrf T (iffH f g).
Proof. intros H H0; apply andI; auto. Qed.

Lemma iffE1 (T : System) (f g : Formula):
  SysPrf T (iffH f g) -> SysPrf T (impH f g).
Proof. intros H; eapply andE1. eexact H. Qed.

Lemma iffE2  (T : System) (f g : Formula):
  SysPrf T (iffH f g) -> SysPrf T (impH g f).
Proof. intros H; eapply andE2, H. Qed.

Lemma forallI (T : System) (f : Formula) (v : nat):
 ~ In_freeVarSys L v T -> SysPrf T f -> SysPrf T (forallH v f).
Proof.
  intros H [x [x0 H0]]; exists x.
  assert (~ In v (freeVarListFormula L x)).
  { intro H1; apply H.
    destruct  (In_freeVarListFormulaE _ _ _ H1) as [x1 H2].
    exists x1; split.
    - tauto.
    - apply H0; tauto.
  }
  exists (GEN L _ _ _ H1 x0); apply H0.
Qed.

Lemma forallE  (T : System) (f : Formula) (v : nat) (t : Term):
 SysPrf T (forallH v f) -> SysPrf T (substituteFormula L f v t).
Proof.
  intro H; apply impE with (forallH v f); [| exact H].
   - exists (nil (A:=Formula)), (FA1 L f v t); contradiction.
Qed.

Lemma forallSimp (T : System) (f : Formula) (v : nat):
 SysPrf T (forallH v f) -> SysPrf T f.
Proof.
  intros H; rewrite <- subFormulaId with L f v;  now apply forallE.
Qed.

Lemma existI (T : System) (f : Formula) (v : nat) (t : Term):
  SysPrf T (substituteFormula L f v t) -> SysPrf T (existH v f).
Proof.
  intros H; unfold existH, fol.existH in |- *;
  apply impE with (notH (notH (substituteFormula L f v t))).
  - apply cp2, impI; rewrite <- (subFormulaNot L).
    apply forallE, Axm; right; constructor.
  - now apply nnI.
Qed.

Lemma existE (T : System) (f g : Formula) (v : nat):
 ~ In_freeVarSys L v T ->
 ~ In v (freeVarFormula L g) ->
 SysPrf T (existH v f) -> SysPrf T (impH f g) -> SysPrf T g.
Proof.
  intros H H0 H1 H2. apply nnE.
  apply impE with (notH (forallH v (notH f))).
  - apply cp2, impI.
    apply impE with (forallH v (notH g)).
    + apply impE with (forallH v (impH (notH g) (notH f))).
      * exists (nil (A:=Formula)).
        exists (FA3 L (notH g) (notH f) v).
        contradiction.
      * apply sysWeaken.
        apply forallI.
        -- apply H.
        -- now apply cp2.
    + apply impE with (notH g).
      * exists (nil (A:=Formula)).
        exists (FA2 L (notH g) v H0).
        contradiction.
      * apply Axm; right; constructor.
  - apply H1.
Qed.

Lemma existSimp  (T : System) (f : Formula) (v : nat) :
 SysPrf T f -> SysPrf T (existH v f).
Proof.
  intros H; eapply existI; now rewrite subFormulaId.
Qed.

Lemma existSys (T : System) (f g : Formula) (v : nat):
 ~ In_freeVarSys L v T ->
 ~ In v (freeVarFormula L g) ->
 SysPrf (Ensembles.Add _ T f) g ->
 SysPrf (Ensembles.Add _ T (existH v f)) g.
Proof.
  intros H H0 H1; eapply existE.
  - intros [x H2]; destruct H.
    exists x.
    destruct H2 as [H2 H3]; split.
    + apply H2.
    + destruct H3 as [x H3| x H3].
      * assumption.
      * induction H3; simpl in H2; absurd (v = v).
        -- eapply in_remove_neq.
           apply H2.
        -- reflexivity.
  - assumption.
  - apply Axm; right; constructor.
  - apply sysWeaken; now apply impI.
Qed.

Section Not_Rules.

Lemma absurd1  (T : System) (f : Formula) :
 SysPrf T (impH f (notH f)) -> SysPrf T (notH f).
Proof.
  intros H; apply orE with (notH f) f.
  - apply noMiddle.
  - apply impI; apply Axm; right; constructor.
  - assumption.
Qed.

Lemma nImp  (T : System) (f g : Formula) :
 SysPrf T (andH f (notH g)) -> SysPrf T (notH (impH f g)).
Proof.
  intros H; apply absurd1.
  apply impI; apply contradiction with g.
  - apply impE with f.
    + apply Axm; right; constructor.
    + eapply andE1.
      apply sysWeaken, H.
  - apply sysWeaken; eapply andE2; apply H.
Qed.

Lemma nOr (T : System) (f g : Formula):
 SysPrf T (andH (notH f) (notH g)) -> SysPrf T (notH (orH f g)).
Proof.
  intros H; apply absurd1, impI, orSys.
  - apply contradiction with f.
    + apply Axm; right; constructor.
    + apply sysWeaken; eapply andE1; apply H.
  - apply contradiction with g.
    + apply Axm; right; constructor.
    + apply sysWeaken; eapply andE2; apply H.
Qed.

Lemma nAnd (T : System) (f g : Formula):
 SysPrf T (orH (notH f) (notH g)) -> SysPrf T (notH (andH f g)).
Proof.
  intros H; unfold andH; apply nnI, H.
Qed.

Lemma nForall  (T : System) (f : Formula) (v : nat) :
 SysPrf T (existH v (notH f)) -> SysPrf T (notH (forallH v f)).
Proof.
  intros H; apply impE with (existH v (notH f)).
  - apply sysExtend with (Empty_set Formula).
    intros g H0. destruct H0.
    apply impI; apply existSys.
    intros [x [H0 H1]]; destruct H1.
    simpl in |- *; intro H0.
    absurd (v = v).
    + eapply in_remove_neq.
      apply H0.
    + reflexivity.
    + apply impE with (notH f).
      * apply cp2, sysWeaken, impI.
        eapply forallSimp.
        apply Axm; right; constructor.
      * apply Axm; right; constructor.
  - assumption.
Qed.

Lemma nExist (T : System) (f : Formula) (v : nat):
 SysPrf T (forallH v (notH f)) -> SysPrf T (notH (existH v f)).
Proof.
  intros H;  now apply nnI.
Qed.

End Not_Rules.

Section Other_Rules.

Lemma impRefl (T : System) (f : Formula):  SysPrf T (impH f f).
Proof.
  apply impI, Axm ; right. constructor.
Qed.

Lemma impTrans (T : System) (f g h : Formula):
 SysPrf T (impH f g) -> SysPrf T (impH g h) ->
 SysPrf T (impH f h).
Proof.
  intros H H0; apply impI; apply impE with g.
  - apply sysWeaken, H0.
  - apply impE with f.
   + apply sysWeaken, H.
   + apply Axm; right; constructor.
Qed.

Lemma orSym (T : System) (f g : Formula):
 SysPrf T (orH f g) -> SysPrf T (orH g f).
Proof.
  intros H; eapply orE.
  - apply H.
  - apply impI, orI2, Axm; right; constructor.
  - apply impI, orI1, Axm; right; constructor.
Qed.

Lemma andSym (T : System) (f g : Formula):
  SysPrf T (andH f g) -> SysPrf T (andH g f).
Proof.
  intros H; apply andI.
  - eapply andE2; apply H.
  - eapply andE1; apply H.
Qed.

Lemma iffRefl (T : System) (f : Formula) :
  SysPrf T (iffH f f).
Proof. apply iffI; apply impRefl. Qed.

Lemma iffSym (T : System) (f g : Formula) :
 SysPrf T (iffH f g) -> SysPrf T (iffH g f).
Proof. intro H; now apply andSym. Qed.

Lemma iffTrans (T : System) (f g h : Formula):
 SysPrf T (iffH f g) -> SysPrf T (iffH g h) ->
 SysPrf T (iffH f h).
Proof.
  intros H H0; apply iffI.
  - eapply impTrans.
    + apply iffE1, H.
    + apply iffE1, H0.
  - eapply impTrans.
    + apply iffE2, H0.
    + apply iffE2, H.
Qed.

End Other_Rules.

Lemma openClosed (T : System) (f : Formula):
 SysPrf T (close L f) -> SysPrf T f.
Proof.
unfold close;
  generalize (List.nodup Peano_dec.eq_nat_dec
                (freeVarFormula L f)); intros l H;
  induction l as [| a l Hrecl].
  - apply H.
  - simpl in H; apply Hrecl; eapply forallSimp; apply H.
Qed.

End Logic_Rules.


From elpi Require Import elpi.
From HB Require Import structures.
From mathcomp Require Import all_ssreflect.
From mathcomp Require ssralg ssrnum zmodp. (* all_algebra *)

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

(** #
#
* The algebra library

 - This is a central part of the mathematical components library.
 - This library register a various range of (mathematical) structures.
  - types with decidable equality: [eqType]
  - types with a finite number of elements: [finType]
  - finite groups: [finGroupType]
  - abelian (not possibly finite) groups: [zmodType]
  - rings: [ringType]
  - rings with invertible elements: [unitRingType]
  - commutative rings: [comRingType]
  - integral domains: [idomainType]
  - fields: [fieldType]
  - left modules: [lmodType]
  - left algebra: [lalgType]
  - algebra: [algType]
  - finite dimensional vector spaces: [vectType]
  - ...

- These structures share operators: e.g. the operator [(_ + _)],
  introduced for abelian groups ([zmodType]), is also available for all
  the structures that inherit it (rings, domains, fields, etc...)

- All of these structures are "discrete": they all have decidable
  equality: the operator [(_ == _)] is available on all of them.

- #  Here is a picture of the begining of the hierarchy#

  Extensive documentation in the header of:
 - #ssralg#
 - #ssrnum#

- In addition there are structures for maps (additive morphisms, ring
  morphisms, etc...), and substructures (subgroup, subsemiring, subring,
  subfield, etc...)

- From math-comp 2.0 alpha, structures are generated by the external tool
  #Hierarchy Builder#

#
# *)
(** -------------------------------------------- *)
(** #
#

* Roadmap for the lesson:
 - introduction of the general definition pattern for algebraic structures
 - instantiation of a structure in the library
 - exploration of the theory provided by this structure and naming
   conventions
 - creation of a algebraic substructure and predicate and their use
#
#
*)
(** -------------------------------------------- *)
(** #
#
* Defining a mathematical structure in Coq.

This is how mathematical structures are defined in the library.
We define structures as sets of "mixins"
(they look more like "traits" in object oriented slang)
#
#
*)
Module AlgebraicStructuresDemo.

HB.mixin Record hasAbsorbingOp T := {
(* symbols: constants and operators *)
  c    : T;
  op   : T -> T -> T;

(* axioms: properties on the symbols *)
  opxc : forall x, op x c = c;
  opC : forall x y, op x y = op y x
}.
(* Absorbing operator structure *)
HB.structure Definition AbsorbingOp := {T of hasAbsorbingOp T}.

HB.about AbsorbingOp.
(*
HB: AbsorbingOp.type is a structure (from "(stdin)", line 16)
HB: AbsorbingOp.type characterizing operations and axioms are:
    - opC
    - opxc
    - op
    - c
HB: AbsorbingOp is a factory for the following mixins:
    - hasAbsorbingOp (* new, not from inheritance *)
*)

(* Notations for the symbols which are immediately available after the definition of the structure*)
Notation "x * y" := (op x y).
Notation "0" := c.

(* Once this is done, we can write the theory associated to this structure *)
Section my_struct_theory.

Variable s : AbsorbingOp.type.

(* Theory of the structure *)
Lemma opcx (x : s) : c * x = c.
Proof. by rewrite opC opxc. Qed.

End my_struct_theory.
(** #

# *)
(** -------------------------------------------- *)
(** #
#
* Defining a mathematical hierarchy in Coq.

Adding a structure is adding more mixins and packaging them into structures.
#
#
*)
HB.mixin Record hasFunnyPred T of hasAbsorbingOp T := {
(* symbols: constants and operators *)
  pr   : pred T;
(* axioms: properties on the symbols *)
  pr_xc : forall x, pr (x * c)
}.
HB.structure Definition Funny :=
  {T of AbsorbingOp T & hasFunnyPred T}.

HB.about Funny.
(*#
HB: Funny.type is a structure (from "(stdin)", line 52)
HB: Funny.type characterizing operations and axioms are:
    - pr_xc
    - pr
HB: Funny is a factory for the following mixins:
    - hasAbsorbingOp
    - hasFunnyPred (* new, not from inheritance *)
HB: Funny inherits from:
    - AbsorbingOp
#*)

Section my_struct2_theory.

Variable s : Funny.type.

(* [pr] becomes immediately available *)
Lemma pr_c : pr (c : s).
Proof. by rewrite -(opcx c) pr_xc. Qed.

Lemma pr_cx (x : s) : pr (c * x).
Proof. by rewrite opC pr_xc. Qed.

End my_struct2_theory.
(** #

# *)
(** -------------------------------------------- *)
(** #
#
* Adding alternative definitions of structures to the hierarchy.

We need a factory and builders
#
# *)
HB.factory Record hasPredOnC T of hasAbsorbingOp T := {
(* symbols: constants and operators *)
  pr   : pred T;
(* axioms: properties on the symbols *)
  pr_c : pr c
}.
HB.builders Context T of hasPredOnC T.
Lemma pr_xc x : pr (x * c). Proof. by rewrite opxc pr_c. Qed.
(* this is a particular case of instanciation, see next section *)
HB.instance Definition _ := hasFunnyPred.Build T pr_xc.
HB.end.

Fail HB.structure Definition already_defined :=
  {T of hasAbsorbingOp T & hasPredOnC T}.

End AlgebraicStructuresDemo.
(** #

#

Hierarchy Builder (HB) now automatically recognizes that [hasPredOnC]
can define a [Funny.type] and only that, hence the failing structure definition.
Now, one can use the factory [hasPredOnC] instead of [hasFunnyPred]
to define a [Funny.type].

#

# *)
(** -------------------------------------------- *)
(** #
#
* Inhabiting the mathematical structures hierarchy.

 - We now show on the example of integers how to instantiate the
   mathematical structures that integers satisfy.

 - In order to minimize the work of the user, the library lets you inhabit
   structures by instanciating mixins and factory, one at a time.
   Each time we want to build structures, we only declare the
   mixin/factory as an [HB.instance].
   One or several structures will be automatically instantiated.

 - We catagorize five different ways to build structures.
   Th three first will be shown here.
   The fourth will be shown in the exercices, and the fifth one won't be shown.

  - using a partially isomorphic structure (and providing the witness).
  - by instanciating just the required mixin from scratch,
  - by instanciating a factory to create one or several structures,
  - by subtyping (in the exercise session),
  - by quotienting (out of scope of the school).

#
# *)
Module InstantiationInteger.

Import ssralg GRing.Theory.
Local Open Scope ring_scope.

(* one can show the currently loaded hierarchy as follows: *)
HB.graph "hierarchy.dot". (* use e.g. tred hierarchy.dot | xdot - *)
(** #

# *)
(** -------------------------------------------- *)
(** #
#
** First we define [int]

#
# *)
Variant int : Set := Posz of nat | Negz of nat.
Local Coercion Posz : nat >-> int.

Notation "n %:Z" := (Posz n)
  (at level 2, left associativity, format "n %:Z", only parsing).
(** #

#

** Equality, countable and choice types, by injection

We provide an injection with explicit partial inverse,
from [int] to [nat + nat], this will be enough to provide the mixins for equality,
countable and choice types.

#

# *)
Definition natsum_of_int (m : int) : nat + nat :=
  match m with Posz p => inl _ p | Negz n => inr _ n end.

Definition int_of_natsum (m : nat + nat) :=
  match m with inl p => Posz p | inr n => Negz n end.

Lemma natsum_of_intK : cancel natsum_of_int int_of_natsum.
Proof. by case. Qed.
(** #
#

We create the mixins for equality, countable and choice types from
this injection, and gradually inhabit the hierarchy.

#
# *)
HB.howto Countable.type.
(* HB: solutions (use 'HB.about F.Build' to see the arguments of each factory F):
    - hasDecEq; hasChoice; isCountable *)

HB.instance Definition _ : hasDecEq int := CanEqMixin natsum_of_intK.
HB.instance Definition _ : hasChoice int := CanChoiceMixin natsum_of_intK.
HB.instance Definition _ : isCountable int := CanCountMixin natsum_of_intK.

(* Advanced way of doing it one go: *)
(* HB.instance Definition _ := Countable.copy int (can_type natsum_of_intK). *)
(** #

# *)
(** -------------------------------------------- *)
(** #
#
** Abelian group structure, from scratch

We now create the abelian group structure of integers (here called
Z-module), from scratch, introducing the operators and proving exactly
the required properties.

#
# *)
Module intZmod.
Section intZmod.
HB.about GRing.isZmodule.Build.
(*# HB: arguments: GRing.isZmodule.Build V [zero] [opp] [add] addrA addrC add0r addNr
    - V : Type
    - zero : GRing.Zmodule.sort V
    - opp : V -> V
    - add : V -> V -> V
    - addrA : associative +%R
    - addrC : commutative +%R
    - add0r : left_id 0 +%R
    - addNr : left_inverse 0 -%R +%R #*)

Definition addz (m n : int) := match m, n with
  | Posz m', Posz n' => Posz (m' + n')
  | Negz m', Negz n' => Negz (m' + n').+1
  | Posz m', Negz n' => if n' < m' then Posz (m' - n'.+1)
                        else Negz (n' - m')
  | Negz n', Posz m' => if n' < m' then Posz (m' - n'.+1)
                          else Negz (n' - m') end.
Definition oppz m := match m with
    | Posz n => if n is (n'.+1)%N then Negz n' else Posz 0
    | Negz n => Posz (n.+1)%N end.
Lemma addzC : commutative addz. Admitted.
Lemma add0z : left_id (Posz 0) addz. Admitted.
Lemma oppzK : involutive oppz. Admitted.
Lemma addzA : associative addz. Admitted.
Lemma addNz : left_inverse (Posz 0) oppz addz. Admitted.

Definition Mixin := GRing.isZmodule.Build int addzA addzC add0z addNz.
End intZmod.
End intZmod.
(* We declare the instance *)
HB.instance Definition _ := intZmod.Mixin.
(*# We can check that int can be converted to a [zmodType] #*)
Check (int : zmodType). (** #

#

Remark: we may develop here a piece of abelian group theory which is
specific to the theory of integers. E.g.
#

# *)Lemma PoszD : {morph Posz : n m / (n + m)%N >-> n + m}.
Proof. by []. Qed. (** #

# *)
(** -------------------------------------------- *)
(** #
#
*** Ring and Commutative ring structure, the stronger the better

This time, we will build directly a rich commutative ring factory first
and use it to instanciate both the ring structure and the commutative
ring struture at the same time. This is not only an economy
of space, but an economy of proofs, since the
commutativity property reduces the number of ring axioms to prove.

#
#
*)
Module intRing.
Section intRing.

HB.howto comRingType.
(*# HB: no solution found at depth 3 looking at depth 4
HB: solutions (use 'HB.about F.Build' to see the arguments of each factory F):
    - hasDecEq; hasChoice; GRing.isRing; GRing.Ring_hasCommutativeMul
    - hasDecEq; hasChoice; GRing.isZmodule; GRing.Zmodule_isComRing #*)

HB.about GRing.Zmodule_isComRing.Build.
(*# HB: arguments: GRing.Zmodule_isComRing.Build R [one] [mul] mulrA mulrC mul1r mulrDl oner_neq0
    - R : Type
    - one : R
    - mul : R -> R -> R
    - mulrA : associative mul
    - mulrC : commutative mul
    - mul1r : left_id one mul
    - mulrDl : left_distributive mul +%R
    - oner_neq0 : is_true (one != 0) #*)

Definition mulz (m n : int) := match m, n with
    | Posz m', Posz n' => (m' * n')%N%:Z
    | Negz m', Negz n' => (m'.+1%N * n'.+1%N)%N%:Z
    | Posz m', Negz n' => - (m' * (n'.+1%N))%N%:Z
    | Negz n', Posz m' => - (m' * (n'.+1%N))%N%:Z end.
Lemma mulzA : associative mulz. Admitted.
Lemma mulzC : commutative mulz. Admitted.
Lemma mul1z : left_id (Posz 1) mulz. Admitted.
Lemma mulz_addl : left_distributive mulz (+%R). Admitted.
Lemma onez_neq0 : (Posz 1) != 0. Proof. by []. Qed.

Definition comMixin := GRing.Zmodule_isComRing.Build int mulzA mulzC mul1z mulz_addl onez_neq0.
End intRing.
End intRing.
(* We declare the instance *)
HB.instance Definition _ := intRing.comMixin.
(*# We can check that [int] can be converted to a [ringType] and a [comRingType] #*)
Check (int : ringType).
Check (int : comRingType).

End InstantiationInteger. (** #
# *)
(** #
# *)
(** -------------------------------------------- *)
(** #
#
* Other structures and instances
#
#
*)
Module OtherStructures.
Import ssralg GRing.Theory.
Local Open Scope ring_scope.
(**
#
#
** About other algebraic structures:

- read the documentation of  #ssralg# and #ssrnum# (algebraic structures with order and absolute value)

- Canonical instances in the library are:
 - integers ([int]) (forms an integral domain)
 - rationals ([rat]) (forms an archimedian field)
 - algebraic numbers ([algC]) (forms an algebraically closed field)
 - polynomials [{poly R}] (forms an integral domain under sufficient hypothesis on the base ring)
 - matrices ['M[R]_(m, n)] (forms a module / a finite dimension vector space)
 - square matrices ['M[R]_n] (forms an algebra, if [n := m.+1])

** Group theory (not in this course):

- see fingroup, perm, action, ...

** Structures for morphisms:
#
#
*)
Search "linear" in ssralg.

Search "raddf" in ssralg.

Search "rmorph" in ssralg.

HB.about GRing.RMorphism.
(** #

** Structure preserving predicates:
#
# *)
Print GRing.subring_closed.
Print GRing.subr_2closed.
Print GRing.mulr_2closed.

Search "rpred" in ssralg.

End OtherStructures.
(** #

# *)
(** -------------------------------------------- *)
(** #
#
* Naming conventions.

The two most important things to get your way out of a situation:
 - Knowing your math
 - Searching the library for what you think you know

For that you have the ssreflect Search command. To use its full power, one should combine seach by identifier (Coq definition), pattern (partial terms) and name (a string contained in the name of the theorem).

The two first methods are straightforward to use (except if you instanciate your patterns more than necessary), but searching by name requires to be aware of naming conventions.

#
# *)
(** -------------------------------------------- *)
(** #
#
** Names in the library are usually obeying one of following the convention

 - #
(condition_)?mainSymbol_suffixes
#
 - #
mainSymbol_suffixes(_condition)?
#

Or in the presence of a property denoted by a nary or unary predicate:
 - #
naryPredicate_mainSymbol+
#
 - #
mainSymbol_unaryPredicate
#

** Where :

 - "mainSymbol" is the most meaningful part of the lemma. It generally
   is the head symbol of the right-hand side of an equation or the
   head symbol of a theorem. It can also simply be the main object of
   study, head symbol or not. It is usually either

  - one of the main symbols of the theory at hand. For example, it will be #opp#, #add#, #mul#, etc...

  - or a special "canonical" operation, such as a ring morphism or a
    subtype predicate. e.g. #linear#, #raddf#, #rmorph#, #rpred#, etc ...

 - "condition" is used when the lemma applies under some hypothesis.

 - "suffixes" are there to refine what shape and/or what other symbols  the lemma has. It can either be the name of a symbol ("add", "mul",  etc...), or the (short) name of a predicate ("#inj#" for "#injectivity#", "#id#" for "identity", ...) or an abbreviation.

Abbreviations are in the header of the file which introduce them. We list here the main abbreviations.

  - A -- associativity, as in #andbA : associative andb.#
  - AC -- right commutativity.
  - ACA -- self-interchange (inner commutativity), e.g.,
        #orbACA : (a || b) || (c || d) = (a || c) || (b || d).#
  - b -- a boolean argument, as in #andbb : idempotent andb.#
  - C -- commutativity, as in #andbC : commutative andb#,
    or predicate complement, as in #predC.#
  - CA -- left commutativity.
  - D -- predicate difference, as in #predD.#
  - E -- elimination, as in #negbFE : ~~ b = false -> b#.
  - F or f -- boolean false, as in #andbF : b && false = false.#
  - I -- left/right injectivity, as in #addbI : right_injective addb# or predicate  intersection, as in #predI.#
  - l -- a left-hand operation, as #andb_orl : left_distributive andb orb.#
  - N or n -- boolean negation, as in #andbN : a && (~~ a) = false.#
  - n -- alternatively, it is a natural number argument
  - P -- a characteristic property, often a reflection lemma, as in
     #andP : reflect (a /\ b) (a && b)#.
  - r -- a right-hand operation, as #orb_andr : right_distributive orb andb.#
      -- alternatively, it is a ring argument
  - T or t -- boolean truth, as in #andbT: right_id true andb.#
  - U -- predicate union, as in #predU#.
  - W -- weakening, as in #in1W : {in D, forall x, P} -> forall x, P.#
  - 0 -- ring 0, as in #addr0 : x + 0 = x.#
  - 1 -- ring 1, as in #mulr1 : x * 1 = x.#
  - D -- ring addition, as in #linearD : f (u + v) = f u + f v.#
  - B -- ring subtraction, as in #opprB : - (x - y) = y - x.#
  - M -- ring multiplication, as in #invfM : (x * y)^-1 = x^-1 * y^-1.#
  - Mn -- ring by nat multiplication, as in #raddfMn : f (x *+ n) = f x *+ n.#
  - mx -- a matrix argument
  - N -- ring opposite, as in #mulNr : (- x) * y = - (x * y).#
  - V -- ring inverse, as in #mulVr : x^-1 * x = 1.#
  - X -- ring exponentiation, as in #rmorphX : f (x ^+ n) = f x ^+ n.#
  - Z -- (left) module scaling, as in #linearZ : f (a *: v)  = s *: f v.#
  - z -- a int operation

** My most used search pattern

#
Search "prefix" "suffix"* (symbol|pattern)* in library.
#

** Examples
#
#
*)
Module Conventions.
Import ssralg ssrnum GRing.Theory.
Local Open Scope ring_scope.

Search *%R "A" in GRing.Theory.

Search "unit" in ssralg.

Search "inj" in ssralg.

Search "rmorph" "M" in ssralg.

Search "rpred" "D" in ssralg.

End Conventions.
(** #

# *)
(** -------------------------------------------- *)
(** #
#
** Revisiting an exercise from session 2

Instead of reasonning using [(_ %| _)] and [(_ %% _)], we switch to ['Z_p]
#
# *)
Section ReasoningModuloInZp.
Import ssralg zmodp GRing.Theory.
Local Open Scope ring_scope.

Lemma pred_Zp k : 1 < k -> k.-1%:R = - 1 :> 'Z_k.
Proof. by case: k => // k k_gt0; rewrite -subn1 natrB ?char_Zp ?sub0r. Qed.

Lemma dvd_exp_odd a k : 0  odd k -> (a.+1 %| (a ^ k).+1).
Proof.
move=> aP kO; apply/eqP; rewrite -val_Zp_nat//.
by rewrite -natr1 natrX pred_Zp// -signr_odd kO addNr.
Qed.

End ReasoningModuloInZp.
(** #

# *)
(** -------------------------------------------- *)
(** #
#
* More about structure preserving predicates.

There is a notion of subobject for a few algebraic concepts.

#
#
**)
Import ssralg GRing.Theory.
Fail HB.howto GRing.SubringClosed.type. (* alpha release sorry *)
HB.howto GRing.SubringClosed.type_.
(* HB: solutions (use 'HB.about F.Build' to see the arguments of each factory F):
    - GRing.isSubringClosed *)
HB.about GRing.isSubringClosed.Build.
(* HB: arguments: GRing.isSubringClosed.Build R S subring_closed_subproof
    - R : ringType
    - S : R -> bool
    - subring_closed_subproof : subring_closed S *)
Print subring_closed.
(* Notation subring_closed := GRing.subring_closed *)
Print GRing.subring_closed.
(* GRing.subring_closed =
fun (R : ringType) (S : {pred R}) => [/\ 1%R \in S, GRing.subr_2closed S & GRing.mulr_2closed S]
     : forall R : ringType, {pred R} -> Prop *)
(** #

See the [hierarchy.dot], use [HB.about], [HB.howto] or read documentation headers to discover other substructure preserving predicates.

# *)
(** -------------------------------------------- *)
(** #
#
 * A reminder on subtyping.

 - In Coq, #sT := {x : T | P x}# is a way to form a
  sigma-type. We say it is a #subtype# if there is only one
  element it #sT# for each element in
  #T#. This happens when #P# is a boolean
  predicate. Another way to form a subtype is to create a record :
  #Record sT := ST {x : T; px : P x}#.

 - In mathcomp, to deal with subtypes independently from how they are
   formed, we have a structure.
#
#
*)
HB.about Sub.
HB.about isSub.

(* In essence *)
Module SubType.
Section SubType.
Variables (T : Type) (P : pred T).
Structure subType : Type := SubType {
  sub_sort :> Type;
  val : sub_sort -> T;
  Sub : forall x, P x -> sub_sort;
  (* elimination rule for sub_sort *)
  _ : forall K (_ : forall x Px, K (@Sub x Px)) u, K u;
  _ : forall x Px, val (@Sub x Px) = x
}.
End SubType.
End SubType.
(**
#

#
 - The most important operators to know on subtypes are
  #val : sT -> T#, #insub : T -> option sT# and
  #insubd : sT -> T -> sT#.

- And the most important theorems to know are
  #val_inj, val_eqE, val_insubd, insubdK# and #insub#

#

#
*)
About val_inj.
About val_eqE.
About insubK.
About val_insubd.
About insubdK.
(** #

# *)
(** -------------------------------------------- *)
(** #
#

* Substructures

Substructures are subtypes that happen to have the same structure as their base type.

There are special factories to instantiate them easily.

#
#
**)
Import ssralg GRing.Theory.
HB.howto GRing.SubRing.type.
(*#
HB: no solution found at depth 3 looking at depth 4
HB: solutions (use 'HB.about F.Build' to see the arguments of each factory F):
    - hasDecEq; isSub; hasChoice; GRing.SubChoice_isSubRing
#*)

HB.about GRing.SubChoice_isSubRing.
(*#
HB: GRing.SubChoice_isSubRing is a factory (from "./ssralg.v", line 5073)
HB: GRing.SubChoice_isSubRing operations and axioms are:
    - subring_closed_subproof
HB: GRing.SubChoice_isSubRing requires the following mixins:
    - hasChoice
    - hasDecEq
    - isSub
HB: GRing.SubChoice_isSubRing provides the following mixins:
    - GRing.Zmodule_isRing
    - GRing.isSubRing
    - GRing.isZmodule
    - GRing.isSubZmodule
#*)
HB.about GRing.SubChoice_isSubRing.Build.
(*#
HB: arguments: GRing.SubChoice_isSubRing.Build R S U subring_closed_subproof
    - R : ringType
    - S : pred R
    - U : Type
    - subring_closed_subproof : subring_closed S
#*)
(** #
#

Moreover, when a predicate is declared as a structure preserving predicate, we can use it to declare a substructure automatically (see exercise session).

*)
(** #
# *)


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.saccheri.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section posidonius_postulate_rah.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma posidonius_postulate__rah : posidonius_postulate -> postulate_of_right_saccheri_quadrilaterals.
Proof.
intro H.
assert (HF : exists A1 A2 B1 B2,
             Per A2 A1 B1 /\ Per A1 A2 B2 /\
             Cong A1 B1 A2 B2 /\ OS A1 A2 B1 B2 /\
             forall A3 B3,
               Col A1 A2 A3 -> Col B1 B2 B3 -> Perp A1 A2 A3 B3 ->
               Cong A3 B3 A1 B1).
  {
  destruct H as [A1' [A2' [B1 [B2 [HNC [HNE [HCop HF]]]]]]].
  destruct (l8_18_existence _ _ _ HNC) as [A1 [HC1 HPerp1]].
  assert_diffs.
  assert (HPar : Par_strict A1' A2' B1 B2).
    {
    split; trivial.
    intros [I [HI1 HI2]].
    assert (HNE' : B1 <> I) by (intro; subst; apply HNC; Col).
    destruct (midpoint_existence B1 I) as [B3 HB3].
    assert (HNE'' : B1 <> B3) by (apply midpoint_distinct_1 in HB3; spliter; auto).
    destruct (l8_18_existence A1' A2' B3) as [A3 [HC4 HPerp3]].
      intro; apply HNC; ColR.
    assert (HCong : Cong A1 B1 A3 B3)
      by (apply HF; Perp; ColR).
    assert (HCong' : Cong B1 I B3 I).
      {
      assert (HNE''' : A3 <> I).
        {
        intro; assert (A1 = A3); treat_equalities.
          {
          apply l8_18_uniqueness with A1' A2' B1; Col.
          apply perp_col0 with A3 B3; Col; Perp.
          }
        assert (HFalse : B3 <> B1) by auto.
        apply HFalse, between_cong with A1; [Between|Cong].
        }
      assert (HNE'''' : B3 <> I).
        {
        apply midpoint_distinct_1 with B1; auto.
        }
      assert (HNE''''' : A1 <> I).
        {
        intro; treat_equalities; apply HNE'''.
        apply l8_18_uniqueness with A1' A2' B3; Col; Perp.
          intro; apply HNC; ColR.
        apply perp_col2_bis with B1 A1; Col.
        }
      destruct (l11_50_2 B1 A1 I B3 A3 I); Cong.

        {
        intro H.
        apply HNE'''.
        apply perp_sym in HPerp1.
        destruct (perp_not_col2 _ _ _ _ HPerp1);
        [apply l6_21 with A1 B1 A1' A2'|apply l6_21 with A1 B1 A2' A1']; ColR.
        }

        {
        apply out2__conga; [|Out].
        repeat split; auto.
        left; apply col_two_sides_bet with B3; [ColR|].
        assert (~ Col A3 B3 B1) by (intro; apply HNE'''; apply l6_21 with A1' A2' B1 B3; Col).
        apply l9_2, l9_8_2 with B1.

          {
          apply invert_two_sides, bet__ts; Between; Col.
          }

          {
          apply l12_6; apply par_not_col_strict with B1; Col.
          apply l12_9 with A1' A2'; Perp; Cop.
          exists I; left; split; Col.
          }
        }

        {
        assert_diffs; apply l11_16; auto;
        apply perp_per_1, perp_col0 with A1' A2'; Perp; Col.
        }
      }
    assert (HFalse : B3 <> B1) by auto.
    apply HFalse, between_cong with I; Between; Cong.
    }
  destruct (l8_18_existence A1' A2' B2) as [A2 [HC2 HPerp2]].
    apply par_strict_not_col_4 with B1, HPar.
  assert (HNE' : A1 <> A2).
    {
    intro; treat_equalities.
    apply HPar; exists A1; split; Col.
    apply cop_perp2__col with A1' A2'; Perp.
    }
  apply perp_right_comm in HPerp1.
  apply perp_right_comm in HPerp2.
  exists A1, A2, B1, B2.
  repeat split; [apply l8_2, perp_per_2, perp_col0 with A1' A2'; auto..|apply HF; Col| |].
    apply (col2_os__os A1' A2'); Side.
  intros A3 B3 HC4 HC5 HPerp3.
  apply HF; Col; [ColR|].
  apply perp_col2 with A1 A2; auto; ColR.
  }
destruct HF as [A [D [B [C [HPer1 [HPer2 [HCong [HOS posid]]]]]]]].
assert (HSac : Saccheri A B C D) by (repeat split; Perp; Cong).
apply (per_sac__rah A B C D); auto.
destruct (midpoint_existence B C) as [M HM].
destruct (midpoint_existence A D) as [N HN].
assert(HPerp := mid2_sac__perp_lower A B C D M N HSac HM HN).
assert_diffs.
assert(Hdiff := sac_distincts A B C D HSac).
spliter.
assert_diffs.
apply (t22_7__per _ _ _ D M N); Between.
  apply perp_per_1, (perp_col1 _ _ _ D); Col; Perp.
apply cong_left_commutativity, posid; Col; Perp.
Qed.

End posidonius_postulate_rah.


(* Authors: Christian Doczkal and Jan-Oliver Kaiser *)
(* Distributed under the terms of CeCILL-B. *)
From mathcomp Require Import all_ssreflect.
From RegLang Require Import misc languages dfa.

Set Default Proof Using "Type".

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

Section NFA.
Variable char : finType.
Local Notation word := (word char).

(** * Nondeterministic Finite Automata.

We define both normal NFAs and NFAs with epsilon transitions
(eNFAs). For NFAs acceptance can still be defined by structural
recursion on the word. In particular, the length of an NFA run is
determined by the input word, a property that we exploit repeatedly. *)

Record nfa : Type := {
    nfa_state :> finType;
    nfa_s : { set nfa_state };
    nfa_fin : { set nfa_state };
    nfa_trans : nfa_state -> char -> nfa_state -> bool }.

Fixpoint nfa_accept (A : nfa) (x : A) w :=
  if w is a :: w' then [exists (y | nfa_trans x a y), nfa_accept y w']
                  else x \in nfa_fin A.

Definition nfa_lang (A : nfa) := [pred w | [exists s, (s \in nfa_s A) && nfa_accept s w]].

(** ** Epsilon NFAs *)

Record enfa : Type := {
  enfa_state :> finType;
  enfa_s : {set enfa_state};
  enfa_f : {set enfa_state};
  enfa_trans : option char -> enfa_state -> enfa_state -> bool }.

Section EpsilonNFA.
  Variables (N : enfa).

  (** For eNFAs, acceptance is defined relationally since structural
  recursion over the word is no longer possible. *)

  Inductive enfa_accept : N -> word -> Prop :=
    | EnfaFin q : q \in enfa_f N -> enfa_accept q [::]
    | EnfaSome p a q x : enfa_trans (Some a) p q -> enfa_accept q x -> enfa_accept p (a::x)
    | EnfaNone p q x : enfa_trans None p q -> enfa_accept q x -> enfa_accept p (x).

  Definition enfa_lang x := exists2 s, s \in enfa_s N & enfa_accept s x.

  (** We convert eNFAs to NFAs by extending the set of starting states and all
  transitions by epsilon-reachable states - also known as epsilon closure *)

  Definition eps_reach (p : N) := [set q | connect (enfa_trans None) p q].

  Lemma lift_accept p q x : q \in eps_reach p -> enfa_accept q x -> enfa_accept p x.
  Proof.
    rewrite inE => /connectP [s]. elim: s p x q => //= [p x q _ -> //| q s IHs p x q'].
    case/andP => pq ? ? H. apply: EnfaNone pq _. exact: IHs H.
  Qed.

  Definition nfa_of :=
    {| nfa_s := \bigcup_(p in enfa_s N) (eps_reach p);
       nfa_fin := enfa_f N;
       nfa_trans p a q := [exists p', enfa_trans (Some a) p p' && (q \in eps_reach p') ] |}.

  Lemma enfaE x p :
    (enfa_accept p x) <-> (exists2 q : nfa_of, q \in eps_reach p & nfa_accept q x).
  Proof. split.
    - elim => {p x} [q H|p a q x H _ [q' Hq1 Hq2]|p p' x].
      + exists q => //. by rewrite inE connect0.
      + exists p => /=; first by rewrite inE connect0.
        apply/exists_inP. exists q' => //. apply/exists_inP. by exists q.
      + move => H1 H2 [q Hq1 Hq2]. exists q => //. rewrite !inE in Hq1 *.
        exact: connect_trans (connect1 _) Hq1.
    - elim: x p => [|a x IH] p [p'] R /= H. apply: lift_accept R _. exact: EnfaFin.
      case/exists_inP : H => q /exists_inP [q' pq' qq'] H. apply: lift_accept R _.
      apply: EnfaSome pq' _. apply: IH. by exists q.
  Qed.

  Lemma nfa_ofP x : reflect (enfa_lang x) (x \in nfa_lang nfa_of).
  Proof.
    apply: (iffP exists_inP) => [[p Hp1 Hp2]|[s Hs1 /enfaE [p Hp1 Hp2]]].
    - case/bigcupP : Hp1 => s Hs H. exists s => //. by apply/enfaE; exists p.
    - exists p => //. by apply/bigcupP; exists s.
  Qed.
End EpsilonNFA.

(** ** Equivalence of DFAs and NFAs *)
(** We use the powerset construction to obtain
   a deterministic automaton from a non-deterministic one. **)
Section PowersetConstruction.

Variable A : nfa.

Definition nfa_to_dfa := {|
  dfa_s := nfa_s A;
  dfa_fin := [set X | X :&: nfa_fin A != set0];
  dfa_trans X a := [set q | [exists (p | p \in X), nfa_trans p a q]]
|}.

Lemma nfa_to_dfa_correct : nfa_lang A =i dfa_lang nfa_to_dfa.
Proof.
  move => w. rewrite !inE {2}/nfa_to_dfa /=.
  elim: w (nfa_s _) => [|a x IH] X; rewrite /= accE ?inE.
  - apply/existsP/set0Pn => [] [p] H; exists p; by rewrite inE in H *.
  - rewrite -IH /dfa_trans /=. apply/exists_inP/exists_inP.
    + case => p inX /exists_inP [q ? ?]. exists q => //. rewrite inE.
      apply/exists_inP. by exists p.
    + case => p. rewrite inE => /exists_inP [q] ? ? ?.
      exists q => //. apply/exists_inP. by exists p.
Qed.

End PowersetConstruction.

(** We also embed NFAs into DFAs. **)

Section Embed.

Variable A : dfa char.

Definition dfa_to_nfa : nfa := {|
  nfa_s := [set dfa_s A];
  nfa_fin := dfa_fin A;
  nfa_trans x a y := dfa_trans x a == y |}.

Lemma dfa_to_nfa_correct : dfa_lang A =i nfa_lang dfa_to_nfa.
Proof.
  move => w. rewrite !inE /nfa_s /=.
  elim: w (dfa_s A) => [|b w IHw] x; rewrite accE /=.
  - apply/idP/existsP => [Fx|[y /andP [/set1P ->]]//].
    exists x. by rewrite !inE eqxx.
  - rewrite IHw. apply/exists_inP/exists_inP.
    + case => y /set1P -> H. exists x; first exact: set11.
      apply/existsP. exists (dfa_trans x b). by rewrite H eqxx.
    + case => y /set1P -> {y} /existsP [z] /andP [] /eqP-> H.
      exists z; by rewrite ?set11.
Qed.

End Embed.

(** ** Operations on NFAs

To prepare the translation from regular expresstions to DFAs, we show
that finite automata are closed under all regular operations. We build
the primitive automata, complement and boolean combinations using
DFAs. *)

Definition nfa_char (a:char) :=
  {| nfa_s := [set false];
     nfa_fin := [set true];
     nfa_trans p b q := if (p,q) is (false,true) then (b == a) else false |}.

Lemma nfa_char_correct (a : char) : nfa_lang (nfa_char a) =1 pred1 [:: a].
Proof.
  move => w /=. apply/exists_inP/eqP => [[p]|].
  - rewrite inE => /eqP->. case: w => [|b [|c w]] /=; first by rewrite inE.
    + by case/exists_inP => [[/eqP->|//]].
    + case/exists_inP => [[_|//]]. by case/exists_inP.
  - move->. exists false; first by rewrite inE. apply/exists_inP.
    exists true; by rewrite ?inE //=.
Qed.

Definition nfa_plus (N M : nfa) :=
  {| nfa_s := [set q | match q with inl q => q \in nfa_s N | inr q => q \in nfa_s M end ];
     nfa_fin := [set q | match q with inl q => q \in nfa_fin N | inr q => q \in nfa_fin M end ];
     nfa_trans p a q := match p,a,q with
                         | inl p,a,inl q => nfa_trans p a q
                         | inr p,a,inr q => nfa_trans p a q
                         | _,_,_ => false
                         end |}.

Lemma nfa_plus_correct (N M : nfa) :
  nfa_lang (nfa_plus N M) =i plus (nfa_lang N) (nfa_lang M).
Proof.
  move => w. apply/idP/idP.
  - case/exists_inP => [[s|s]]; rewrite !inE => A B;
    apply/orP;[left|right];apply/exists_inP; exists s => //.
    + elim: w s {A} B => /= [|a w IH] s; first by rewrite inE.
      case/exists_inP => [[|]// p A /IH B]. apply/exists_inP. by exists p.
    + elim: w s {A} B => /= [|a w IH] s; first by rewrite inE.
      case/exists_inP => [[|]// p A /IH B]. apply/exists_inP. by exists p.
  - rewrite !inE. case/orP => /exists_inP [s A B];
    apply/exists_inP; [exists(inl s)|exists(inr s)]; rewrite ?inE //.
    + elim: w s {A} B => /= [|a w IH] s; first by rewrite inE.
      case/exists_inP => [p A /IH B]. apply/exists_inP. by exists (inl p).
    + elim: w s {A} B => /= [|a w IH] s; first by rewrite inE.
      case/exists_inP => [p A /IH B]. apply/exists_inP. by exists (inr p).
Qed.

Definition nfa_eps : nfa :=
  {| nfa_s := [set tt]; nfa_fin := [set tt]; nfa_trans p a q := false |}.

Lemma nfa_eps_correct: nfa_lang (nfa_eps) =i pred1 [::].
Proof.
  move => w. apply/exists_inP/idP.
  + move => [[]]. case: w => [|a w] //= _. by case/exists_inP.
  + move => /=. rewrite inE=>/eqP->. exists tt; by rewrite /= inE.
Qed.

(** The automata for concatenation and Kleene star are constructed by
taking NFAs as input and first building eNFAs which are then converted
to NFAs. *)

Section eNFAOps.

Variables A1 A2 : nfa.

Definition enfa_conc : enfa :=
  {| enfa_s := inl @: nfa_s A1;
     enfa_f := inr @: nfa_fin A2;
     enfa_trans c p q :=
       match c,p,q with
         | Some a,inl p',inl q' => nfa_trans p' a q'
         | Some a,inr p',inr q' => nfa_trans p' a q'
         | None,inl p', inr q' => (p' \in nfa_fin A1) && (q' \in nfa_s A2)
         | _,_,_ => false
       end |}.

Lemma enfa_concE (p : enfa_conc) x : enfa_accept p x ->
  match p with
    | inr p' => nfa_accept p' x
    | inl p' => exists x1 x2, [/\ x = x1 ++ x2, nfa_accept p' x1 & x2 \in nfa_lang A2]
  end.
Proof.
  elim => {p x} [[?|?] /imsetP [q] // ? [->] //||].
  - move => [p|p] a [q|q] x //.
    + move => pq _ [x1] [x2] [X1 X2 X3]. exists (a::x1); exists x2; subst; split => //.
      by apply/exists_inP; exists q.
    + move => pq _ Hq. by apply/exists_inP; exists q.
  - move => [p|p] [q|q] //= x /andP[Hp Hq] _ ?. exists [::]; exists x; split => //.
    by apply/exists_inP; exists q.
Qed.

Lemma enfa_concIr (p : A2) x : nfa_accept p x -> @enfa_accept enfa_conc (inr p) x.
Proof.
  elim: x p => [p Hp|a x IH p /= /exists_inP [q q1 q2]].
  - (* compat: <mathcomp-1.12 *)
    constructor; solve [exact: imset_f|exact:mem_imset].
  - apply: (@EnfaSome enfa_conc _ _ (inr q)) => //. exact: IH.
Qed.

Lemma enfa_concIl (p : A1) x1 x2 :
  nfa_accept p x1 -> x2 \in nfa_lang A2 -> @enfa_accept enfa_conc (inl p) (x1++x2).
Proof.
  elim: x1 p => /= [p Hp /exists_inP [q q1 q2]|a x1 IH p /exists_inP [q q1 q2] H].
  - apply: (@EnfaNone enfa_conc _ (inr q)). by rewrite /= Hp. exact: enfa_concIr.
  - apply: (@EnfaSome enfa_conc _ _ (inl q)). by rewrite /= q1. exact: IH.
Qed.

Lemma enfa_concP x : reflect (enfa_lang enfa_conc x) (conc (nfa_lang A1) (nfa_lang A2) x).
Proof.
  apply: (iffP (@concP _ _ _ _)) => [[x1] [x2] [X1 [X2 X3]] |].
  - (* compat: <mathcomp-1.12 *)
    case/exists_inP : X2 => s ? ?. exists (inl s); first solve [exact: imset_f|exact:mem_imset].
    subst. exact: enfa_concIl.
  - move => [[s /imsetP [? ? [?]] /enfa_concE [x1] [x2] [? ? ?] |s]]; last by case/imsetP.
    exists x1; exists x2. repeat (split => //). apply/exists_inP. by exists s;subst.
Qed.

Definition enfa_star : enfa :=
  {| enfa_s := [set None];
     enfa_f := [set None];
     enfa_trans c p q :=
       match c,p,q with
           Some a,Some p', Some q' => q' \in nfa_trans p' a
         | None, Some p', None => p' \in nfa_fin A1
         | None, None, Some s => s \in nfa_s A1
         | _,_,_ => false
       end |}.

Lemma enfa_s_None : None \in enfa_s enfa_star.
Proof. by rewrite inE. Qed.

Lemma enfa_f_None : None \in enfa_f enfa_star.
Proof. by rewrite inE. Qed.

Hint Resolve enfa_s_None enfa_f_None : core.

Lemma enfa_star_cat x1 x2 (p : enfa_star) :
  enfa_accept p x1 -> enfa_lang enfa_star x2 -> enfa_accept p (x1 ++ x2).
Proof.
  elim => {p x1}.
  - move => p. rewrite inE => /eqP->. case => q. by rewrite inE => /eqP->.
  - move => p a q x /=. case: p => // p. case: q => // q pq ? IH H. exact: EnfaSome (IH H).
  - move => [p|] [q|] x //= p1 p2 IH H; exact: EnfaNone (IH H).
Qed.

Lemma enfa_starI x (p : A1) : nfa_accept p x -> @enfa_accept enfa_star (Some p) x.
Proof.
  elim: x p => /= [p H|a x IH p].
  - apply: (@EnfaNone enfa_star _ None) => //. exact: EnfaFin.
  - case/exists_inP => q q1 /IH. exact: EnfaSome.
Qed.

Lemma enfa_star_langI x : x \in nfa_lang A1 -> @enfa_accept enfa_star None x.
Proof.
  case/exists_inP => s s1 s2.
  apply: (@EnfaNone enfa_star _ (Some s)) => //. exact: enfa_starI.
Qed.

Lemma enfa_starE (o : enfa_star) x : enfa_accept o x ->
  if o is Some p
  then exists x1 x2, [/\ x = x1 ++ x2, nfa_accept p x1 & star (nfa_lang A1) x2]
  else star (nfa_lang A1) x.
Proof.
  elim => {x o}.
  - move => [q|//]. by rewrite inE; move/eqP.
  - move => [p|] a [q|] x // H acc [x1] [x2] [H1 H2 H3]. exists (a::x1); exists x2.
    rewrite H1. split => //. by apply/exists_inP; exists q.
  - move => [p|] [q|] x //=.
    + move => *. by exists [::]; exists x.
    + move => H acc [x1] [x2] [H1 H2]. rewrite H1. apply: star_cat.
      by apply/exists_inP; exists q.
Qed.

Lemma enfa_starP x : reflect (enfa_lang enfa_star x) (star (nfa_lang A1) x).
Proof. apply: (iffP idP).
  - case/starP => vv H ->. elim: vv H => /= [_|v vv].
    + exists None => //. exact: EnfaFin.
    + move => IH /andP[/andP [H1 H2] H3]. exists None => //.
      apply: enfa_star_cat (IH _) => //. exact: enfa_star_langI.
  - case => q. rewrite inE => /eqP-> {q}. exact: enfa_starE.
Qed.

Definition nfa_conc := nfa_of (enfa_conc).

Lemma nfa_conc_correct : nfa_lang nfa_conc =i conc (nfa_lang A1) (nfa_lang A2).
Proof. move => x. apply/nfa_ofP/idP => ?;exact/enfa_concP. Qed.

Definition nfa_star := nfa_of (enfa_star).
Lemma nfa_star_correct : nfa_lang nfa_star =i star (nfa_lang A1).
Proof. move => x. apply/nfa_ofP/idP => ?;exact/enfa_starP. Qed.

End eNFAOps.

(** ** Runs on NFAs *)

Section NFARun.
  Variable (M : nfa).

  Inductive nfa_run : word -> M -> seq M -> Prop :=
    | run0 p of p \in nfa_fin M : nfa_run [::] p [::]
    | runS a p q x r & q \in nfa_trans p a : nfa_run x q r -> nfa_run (a::x) p (q::r).

  Lemma nfa_acceptP x p : reflect (exists r, nfa_run x p r) (nfa_accept p x).
  Proof.
    apply: (iffP idP) => [|[r]].
    - elim: x p => [|a x IHx] p /=; first by exists [::]; constructor.
      case/exists_inP => q p1 p2. case (IHx q p2) => r ?. by exists (q::r); constructor.
    - elim: x r p => [|a x IHx] r p; first by inversion 1; subst.
      inversion 1; subst. apply/exists_inP. exists q => //. exact: IHx H4.
  Qed.

  Lemma run_size x r p : nfa_run x p r -> size x = size r.
  Proof. by elim => // {r p x} a p q r x _ _ /= ->. Qed.

  Lemma nfaP x : reflect (exists s r, s \in nfa_s M /\ nfa_run x s r) (x \in nfa_lang M).
  Proof.
    apply: (iffP exists_inP).
    - case => s ? /nfa_acceptP [r] ?. by exists s; exists r.
    - case => s [r] [? ?]. exists s => //. apply/nfa_acceptP. by exists r.
  Qed.

  Lemma run_last x p r : nfa_run x p r -> last p r \in nfa_fin M.
  Proof. by elim. Qed.

  Lemma run_trans x p r i (Hi : i < size x) : nfa_run x p r ->
    nth p (p::r) i.+1 \in nfa_trans (nth p (p::r) i) (tnth (in_tuple x) (Ordinal Hi)).
  Proof.
    move => H. elim: H i Hi => {x p r} // a p q x r tr run IH /= [|i] Hi //.
    rewrite !(set_nth_default q); try by rewrite /= -(run_size run) // ltnW.
    rewrite {1}[nth]lock (tnth_nth a) /=. rewrite ltnS in Hi.
    rewrite -{3}[i]/(nat_of_ord (Ordinal Hi)).
    by rewrite -[x]/(tval (in_tuple x)) -tnth_nth -lock IH.
  Qed.

  (** The following lemma uses [in_tuple] and [tnth] in order to avoid
  having to assume the existence of a default symbol *)

  Lemma runI x s r :
    size r = size x -> last s r \in nfa_fin M ->
    (forall i : 'I_(size x),
       nth s (s::r) i.+1 \in nfa_trans (nth s (s::r) i) (tnth (in_tuple x) i)) ->
    nfa_run x s r.
  Proof.
    elim: x s r => [|a x IHx ] s r /=.
    - move/eqP => e inF _. rewrite size_eq0 in e. rewrite (eqP e) in inF *. exact: run0.
    - case: r => // p r /eqP /=. rewrite eqSS => /eqP R1 R2 I.
      apply: runS (I ord0) _ => /=. apply: IHx => // i.
      move: (I (inord i.+1)). rewrite /tnth /= !inordK /= ?ltnS //.
      rewrite !(set_nth_default p) /= ?R1 // 1?ltnW ?ltnS //.
      by rewrite -[x]/(val (in_tuple x)) -!tnth_nth.
  Qed.

End NFARun.

(** Decidability of Language Emptiness *)

Definition nfa_inhab (N : nfa) := dfa_inhab (nfa_to_dfa N).

Lemma nfa_inhabP N : reflect (exists w, w \in nfa_lang N) (nfa_inhab N).
Proof.
  apply: (iffP (dfa_inhabP _)).
  - move => [x]. rewrite -nfa_to_dfa_correct. by exists x.
  - move => [x ?]. exists x. by rewrite -nfa_to_dfa_correct.
Qed.

Lemma nfa_regular L :
  regular L <-T->  { N : nfa  | forall x, L x <-> x \in nfa_lang N }.
Proof.
  split => [[A]|[N]] H.
  exists (dfa_to_nfa A) => x. by rewrite -dfa_to_nfa_correct.
  exists (nfa_to_dfa N) => x. by rewrite -nfa_to_dfa_correct.
Qed.

End NFA.

Arguments nfaP {char M x}.


Require Import init.

Require Export list_base.
Require Import list_in.

Require Import set.

Fixpoint list_filter {U} (S : U → Prop) (l : list U) :=
    match l with
    | [] => []
    | x ꞉ l' => If S x then x ꞉ list_filter S l' else list_filter S l'
    end.
Arguments list_filter : simpl never.

Fixpoint list_prop {U} (S : U → Prop) (l : list U) :=
    match l with
    | [] => True
    | a ꞉ l' => S a ∧ list_prop S l'
    end.
Arguments list_prop : simpl never.

(** Note that this only checks all pairs from left to right and doesn't evaluate
S on an element with itself.  If you want both directions, give an S that
manually checks both directions, and if you want to check an element with
itself, use list_prop. *)
Fixpoint list_prop2 {U} (S : U → U → Prop) (l : list U) :=
    match l with
    | [] => True
    | a ꞉ l' => list_prop (S a) l' ∧ list_prop2 S l'
    end.
Arguments list_prop2 : simpl never.

Theorem list_filter_end {U} : ∀ (S : U → Prop), list_filter S [] = [].
Proof.
    reflexivity.
Qed.

Theorem list_filter_add_in {U} : ∀ {S : U → Prop} {a l},
    S a → list_filter S (a ꞉ l) = a ꞉ list_filter S l.
Proof.
    intros S a l Sa.
    unfold list_filter; fold (list_filter (U := U)).
    rewrite (if_true Sa).
    reflexivity.
Qed.

Theorem list_filter_add_nin {U} : ∀ {S : U → Prop} {a l},
    ¬S a → list_filter S (a ꞉ l) = list_filter S l.
Proof.
    intros S a l Sa.
    unfold list_filter; fold (list_filter (U := U)).
    rewrite (if_false Sa).
    reflexivity.
Qed.

Theorem list_filter_single_in {U} : ∀ (S : U → Prop) a,
    S a → list_filter S [a] = [a].
Proof.
    intros S a Sa.
    rewrite (list_filter_add_in Sa).
    rewrite list_filter_end.
    reflexivity.
Qed.

Theorem list_filter_single_nin {U} : ∀ (S : U → Prop) a,
    ¬S a → list_filter S [a] = [].
Proof.
    intros S a Sa.
    rewrite (list_filter_add_nin Sa).
    rewrite list_filter_end.
    reflexivity.
Qed.

Theorem list_filter_conc {U} : ∀ (S : U → Prop) l1 l2,
    list_filter S (l1 + l2) = list_filter S l1 + list_filter S l2.
Proof.
    intros S l1 l2.
    induction l1 as [|a l1].
    -   rewrite list_filter_end.
        do 2 rewrite list_conc_lid.
        reflexivity.
    -   rewrite list_conc_add.
        classic_case (S a) as [Sa|Sa].
        +   do 2 rewrite (list_filter_add_in Sa).
            rewrite IHl1.
            rewrite list_conc_add.
            reflexivity.
        +   do 2 rewrite (list_filter_add_nin Sa).
            exact IHl1.
Qed.

Lemma list_filter_in_both {U} : ∀ S (l : list U) x,
    in_list (list_filter S l) x → in_list l x ∧ S x.
Proof.
    intros S l x x_in.
    induction l.
    -   rewrite list_filter_end in x_in.
        contradiction x_in.
    -   rewrite in_list_add.
        classic_case (S a) as [Sa|Sa].
        +   rewrite (list_filter_add_in Sa) in x_in.
            rewrite in_list_add in x_in.
            destruct x_in as [x_eq|x_in].
            *   subst a.
                split; [>|exact Sa].
                left; reflexivity.
            *   specialize (IHl x_in).
                split; [>|apply IHl].
                right; apply IHl.
        +   rewrite (list_filter_add_nin Sa) in x_in.
            specialize (IHl x_in).
            split; [>|apply IHl].
            right; apply IHl.
Qed.

Theorem list_filter_in {U} : ∀ S (l : list U) x,
    in_list (list_filter S l) x → in_list l x.
Proof.
    intros S l x x_in.
    apply (list_filter_in_both S l x x_in).
Qed.

Theorem list_filter_in_set {U} : ∀ S (l : list U) x,
    in_list (list_filter S l) x → S x.
Proof.
    intros S l x x_in.
    apply (list_filter_in_both S l x x_in).
Qed.

Theorem list_filter_unique {U} : ∀ S (l : list U),
    list_unique l → list_unique (list_filter S l).
Proof.
    intros S l l_uni.
    list_unique_induction l l_uni as a a_nin IHl.
    -   rewrite list_filter_end.
        apply list_unique_end.
    -   classic_case (S a) as [Sa|Sa].
        +   rewrite (list_filter_add_in Sa).
            rewrite list_unique_add.
            split.
            *   contrapositive a_nin.
                apply list_filter_in.
            *   exact IHl.
        +   rewrite (list_filter_add_nin Sa).
            exact IHl.
Qed.

Theorem list_filter_image_in {U V} : ∀ S (f : U → V) (l : list U) x,
    in_list (list_image f (list_filter S l)) x → in_list (list_image f l) x.
Proof.
    intros S f l y y_in.
    apply image_in_list in y_in as [x [x_eq x_in]].
    subst y.
    apply in_list_image.
    exact (list_filter_in _ _ _ x_in).
Qed.

Theorem list_filter_image_unique {U V} : ∀ S (f : U → V) (l : list U),
    list_unique (list_image f l) →
    list_unique (list_image f (list_filter S l)).
Proof.
    intros S f l l_uni.
    induction l as [|a l].
    -   rewrite list_filter_end, list_image_end.
        apply list_unique_end.
    -   rewrite list_image_add, list_unique_add in l_uni.
        destruct l_uni as [fa_nin l_uni].
        specialize (IHl l_uni).
        classic_case (S a) as [Sa|Sa].
        +   rewrite (list_filter_add_in Sa).
            rewrite list_image_add, list_unique_add.
            split.
            *   contrapositive fa_nin.
                apply list_filter_image_in.
            *   exact IHl.
        +   rewrite (list_filter_add_nin Sa).
            exact IHl.
Qed.

Theorem list_filter_inter {U} : ∀ S T (l : list U),
    list_filter S (list_filter T l) = list_filter (S ∩ T) l.
Proof.
    intros S T l.
    induction l.
    -   do 2 rewrite list_filter_end.
        reflexivity.
    -   classic_case (T a) as [Ta|Ta]; [>classic_case (S a) as [Sa|Sa]|].
        +   rewrite (list_filter_add_in Ta).
            rewrite (list_filter_add_in Sa).
            rewrite (list_filter_add_in ((make_and Sa Ta) : (S ∩ T) a)).
            apply f_equal.
            exact IHl.
        +   assert (¬(S ∩ T) a) as STa by (intros [Sa' Ta']; contradiction).
            rewrite (list_filter_add_in Ta).
            rewrite (list_filter_add_nin Sa).
            rewrite (list_filter_add_nin STa).
            exact IHl.
        +   assert (¬(S ∩ T) a) as STa by (intros [Sa' Ta']; contradiction).
            rewrite (list_filter_add_nin Ta).
            rewrite (list_filter_add_nin STa).
            exact IHl.
Qed.

Theorem list_filter_filter {U} : ∀ S (l : list U),
    list_filter S (list_filter S l) = list_filter S l.
Proof.
    intros S l.
    rewrite list_filter_inter.
    rewrite inter_idemp.
    reflexivity.
Qed.

Theorem list_prop_end {U} : ∀ S : U → Prop, list_prop S [].
Proof.
    intros S.
    exact true.
Qed.

Theorem list_prop_add {U} : ∀ S (a : U) l,
    list_prop S (a ꞉ l) ↔ S a ∧ list_prop S l.
Proof.
    reflexivity.
Qed.

Theorem list_prop_single {U} : ∀ S (a : U), list_prop S [a] ↔ S a.
Proof.
    intros S a.
    rewrite list_prop_add.
    rewrite (prop_is_true (list_prop_end S)).
    apply and_rtrue.
Qed.

Tactic Notation "list_prop_induction" ident(l) ident(P) "as"
    simple_intropattern(a) simple_intropattern(nin) simple_intropattern(IHl) :=
    move P before l;
    induction l as [|a l IHl];
    [>|
        rewrite list_prop_add in P;
        specialize (IHl (rand P));
        destruct P as [nin P]
    ].

Theorem list_prop_conc {U} : ∀ S (l1 l2 : list U),
    list_prop S (l1 + l2) ↔ list_prop S l1 ∧ list_prop S l2.
Proof.
    intros S l1 l2.
    induction l1.
    -   rewrite list_conc_lid.
        rewrite (prop_is_true (list_prop_end S)).
        rewrite and_ltrue.
        reflexivity.
    -   rewrite list_conc_add.
        do 2 rewrite list_prop_add.
        rewrite IHl1.
        rewrite and_assoc.
        reflexivity.
Qed.

Theorem list_prop_sub {U} : ∀ (l : list U) S T, S ⊆ T →
    list_prop S l → list_prop T l.
Proof.
    intros l S T sub Sl.
    list_prop_induction l Sl as a Sa IHl.
    -   apply list_prop_end.
    -   rewrite list_prop_add.
        apply sub in Sa.
        split; assumption.
Qed.

Theorem list_prop_filter {U} : ∀ (l : list U) S, list_prop S (list_filter S l).
Proof.
    intros l S.
    induction l.
    -   rewrite list_filter_end.
        apply list_prop_end.
    -   classic_case (S a) as [Sa|Sa].
        +   rewrite (list_filter_add_in Sa).
            rewrite list_prop_add.
            split; assumption.
        +   rewrite (list_filter_add_nin Sa).
            exact IHl.
Qed.

Theorem list_prop_in {U} : ∀ (a : list U) S, list_prop S a →
    ∀ x, in_list a x → S x.
Proof.
    intros a S a_in x x_in.
    list_prop_induction a a_in as y Sy IHl.
    -   contradiction x_in.
    -   rewrite in_list_add in x_in.
        destruct x_in as [eq|x_in].
        +   subst.
            exact Sy.
        +   exact (IHl x_in).
Qed.

Theorem list_prop_in_sub {U} : ∀ {a b : list U} {S},
    list_prop S b → (∀ x, in_list a x → in_list b x) → list_prop S a.
Proof.
    intros a b S b_in sub.
    induction a as [|x a].
    -   apply list_prop_end.
    -   rewrite list_prop_add.
        split.
        +   apply (list_prop_in _ _ b_in).
            apply sub.
            rewrite in_list_add.
            left; reflexivity.
        +   apply IHa.
            intros y y_in.
            apply sub.
            rewrite in_list_add.
            right; exact y_in.
Qed.

Theorem list_prop_other_filter {U} : ∀ (l : list U) S T,
    list_prop S l → list_prop S (list_filter T l).
Proof.
    intros l S T Sl.
    apply (list_prop_in_sub Sl).
    apply list_filter_in.
Qed.

Theorem list_prop2_end {U} : ∀ S : U → U → Prop, list_prop2 S [].
Proof.
    intros S.
    exact true.
Qed.

Theorem list_prop2_add {U} : ∀ S (a : U) l,
    list_prop2 S (a ꞉ l) ↔ list_prop (S a) l ∧ list_prop2 S l.
Proof.
    reflexivity.
Qed.

Theorem list_prop2_single {U} : ∀ S (a : U), list_prop2 S [a].
Proof.
    intros S a.
    rewrite list_prop2_add.
    split.
    -   apply list_prop_end.
    -   apply list_prop2_end.
Qed.


From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool ssrnat eqtype fintype.
Set Implicit Arguments.

Require Import compcert.lib.Axioms.

Record pos := mkPos { n :> nat ; N_pos : (0 < n)%coq_nat }.

Lemma is_pos (p : pos) : 0 < p.
Proof. by case: p=> m pf; apply/ltP. Qed.

Definition i0 (p : pos) : 'I_p := Ordinal (is_pos p).

Require Import Omega.
Lemma is_pos_incr (n : nat) : (0 < n.+1)%coq_nat.
Proof. omega. Qed.

Definition pos_incr (p : pos) : pos := mkPos (is_pos_incr p).

Lemma pos_incr_lt (p : pos) : p < pos_incr p.
Proof. by []. Qed.

Definition ordinal_pos_incr (p : pos) : 'I_(pos_incr p) := Ordinal (pos_incr_lt p).

Section PosEqType.

Definition pos_eq := [rel u v : pos | n u == n v].

Lemma pos_eqP : Equality.axiom pos_eq.
Proof.
move=> /=; case=> n0 pf0; case=> n1 pf1.
case Heq: (n0 == n1).
{ move: (eqP Heq) pf0 pf1=> -> pf0 pf1.
   have ->: pf0 = pf1 by apply: proof_irr.
   by apply: ReflectT.
}
{ apply: ReflectF; case=> Heq1.
   by move: Heq; rewrite Heq1; move/eqP; apply.
}
Qed.

Definition pos_eqMixin := EqMixin pos_eqP.
Canonical pos_eqType := Eval hnf in EqType pos pos_eqMixin.

Lemma pos_eqE : pos_eq = eq_op :> rel _. Proof. by []. Qed.

End PosEqType.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq bigop.

Module Suspension.

  Import ArrivalSequence.

  (* First, we define the actual job suspension times. *)
  Section SuspensionTimes.

    (* Consider any type of job. *)
    Variable Job: eqType.

    (* We define job suspension as a function that takes a job in the arrival
       sequence and its current service and returns how long the job must
       suspend next. *)
    Definition job_suspension := Job ->    (* job *)
                                 time ->   (* current service *)
                                 duration. (* duration of next suspension *)

  End SuspensionTimes.

  (* Next, we define the total suspension time incurred by a job. *)
  Section TotalSuspensionTime.

    Context {Job: eqType}.
    Variable job_cost: Job -> time.

    (* Consider any job suspension function. *)
    Variable next_suspension: job_suspension Job.

    (* Let j be any job. *)
    Variable j: Job.

    (* We define the total suspension time incurred by job j as the cumulative
       duration of each suspension point t in the interval [0, job_cost j). *)
    Definition total_suspension :=
      \sum_(0 <= t < job_cost j) (next_suspension j t).

  End TotalSuspensionTime.

  (* In this section, we define the dynamic self-suspension model as an
     upper bound on the total suspension times. *)
  Section DynamicSuspensions.

    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> Task.

    (* Consider any job arrival sequence subject to job suspensions. *)
    Variable next_suspension: job_suspension Job.

    (* Recall the definition of total suspension time. *)
    Let total_job_suspension := total_suspension job_cost next_suspension.

    (* Next, assume that for each task a suspension bound is known. *)
    Variable suspension_bound: Task -> duration.

    (* Then, we say that the arrival sequence satisfies the dynamic
       suspension model iff the total suspension time of each job is no
       larger than the suspension bound of its task. *)
    Definition dynamic_suspension_model :=
      forall j, total_job_suspension j <= suspension_bound (job_task j).

  End DynamicSuspensions.

End Suspension.


(*******************************************************************************
*                                                                              *
*   Definitions.v                                                              *
*   Xuejing Huang 2021                                                         *
*   Distributed under the terms of the GPL-v3 license                          *
*                                                                              *
*   This file is part of DistributingTypes.                                    *
*                                                                              *
*   DistributingTypes is free software: you can redistribute it and/or modify  *
*   it under the terms of the GNU General Public License as published by       *
*   the Free Software Foundation, either version 3 of the License, or          *
*   (at your option) any later version.                                        *
*                                                                              *
*   DistributingTypes is distributed in the hope that it will be useful,       *
*   but WITHOUT ANY WARRANTY; without even the implied warranty of             *
*   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *
*   GNU General Public License for more details.                               *
*                                                                              *
*   You should have received a copy of the GNU General Public License          *
*   along with DistributingTypes.  If not, see <https://www.gnu.org/licenses/>.*
*                                                                              *
*******************************************************************************)

(* generated by Ott 0.31 from: ../spec/rules.ott *)
(* some comments are added manually *)

Require Import Arith.
Require Import Bool.
Require Import List.

(***************************************************************)
(** definitions of syntax and auxiliary functions **)

(* This is Type defined at the beginning of Sec 3.1 *)
Inductive typ : Set :=  (* types *)
 | t_int : typ (* int *)
 | t_top : typ (* top type *)
 | t_bot : typ (* bottom type *)
 | t_arrow (A:typ) (B:typ) (* function type *)
 | t_and (A:typ) (B:typ) (* intersection *)
 | t_or (A:typ) (B:typ) (* union *).

(* This is Mode defined at the beginning of Sec 4.1 *)
Inductive mode : Set :=
 | m_sub : mode (* subtyping *)
 | m_super : mode (* supertyping *).

(* These three functions are defined at the top of Fig. 7 *)
Definition typbymode (m: mode) :=
  match m with
  | m_sub => t_top
  | m_super => t_bot
  end.

Definition choose (m: mode) (A: typ) (B: typ) :=
  match m with
  | m_sub => t_and A B
  | m_super => t_or A B
  end.

Definition flipmode (m: mode) :=
  match m with
  | m_sub => m_super
  | m_super => m_sub
  end.

(***************************************************************)
(** definitions of subtyping / duotyping relations **)

(* This is declarative subtyping defined in Fig. 4 *)
Inductive declarative_subtyping : typ -> typ -> Prop :=
 | DS_refl : forall (A:typ),
     declarative_subtyping A A
 | DS_trans : forall (A C B:typ),
     declarative_subtyping A B ->
     declarative_subtyping B C ->
     declarative_subtyping A C
 | DS_top : forall (A:typ),
     declarative_subtyping A t_top
 | DS_bot : forall (A:typ),
     declarative_subtyping t_bot A
 | DS_arrow : forall (A C B D:typ),
     declarative_subtyping B A ->
     declarative_subtyping C D ->
     declarative_subtyping (t_arrow A C) (t_arrow B D)
 | DS_and : forall (A B C:typ),
     declarative_subtyping A B ->
     declarative_subtyping A C ->
     declarative_subtyping A (t_and B C)
 | DS_andl : forall (A B:typ),
     declarative_subtyping (t_and A B) A
 | DS_andr : forall (A B:typ),
     declarative_subtyping (t_and A B) B
 | DS_or : forall (A B C:typ),
     declarative_subtyping A C ->
     declarative_subtyping B C ->
     declarative_subtyping (t_or A B) C
 | DS_orl : forall (A B:typ),
     declarative_subtyping A (t_or A B)
 | DS_orr : forall (B A:typ),
     declarative_subtyping B (t_or A B)
 | DS_distArr : forall (A B1 B2:typ),
     declarative_subtyping (t_and  (t_arrow A B1)   (t_arrow A B2) ) (t_arrow A (t_and B1 B2))
 | DS_distArrRev : forall (A B1 B2:typ),
     declarative_subtyping (t_arrow A (t_and B1 B2)) (t_and  (t_arrow A B1)   (t_arrow A B2) )
 | DS_distArrU : forall (A1 B A2:typ),
     declarative_subtyping (t_and  (t_arrow A1 B)   (t_arrow A2 B) ) (t_arrow (t_or A1 A2) B)
 | DS_distArrURev : forall (A1 A2 B:typ),
     declarative_subtyping (t_arrow (t_or A1 A2) B) (t_and  (t_arrow A1 B)   (t_arrow A2 B) )
 | DS_distOr : forall (A1 B A2:typ),
     declarative_subtyping (t_and  (t_or A1 B)   (t_or A2 B) ) (t_or  (t_and A1 A2)  B)
 | DS_distAnd : forall (A1 A2 B:typ),
     declarative_subtyping (t_and  (t_or A1 A2)  B) (t_or  (t_and A1 B)   (t_and A2 B) ).

(* This is declarative subtyping defined in Fig. 4 minus DS_distAnd *)
(* It is only used in DistAnd.v *)
Inductive declarative_subtyping_distor : typ -> typ -> Prop :=
 | DSO_refl : forall (A:typ),
     declarative_subtyping_distor A A
 | DSO_trans : forall (A C B:typ),
     declarative_subtyping_distor A B ->
     declarative_subtyping_distor B C ->
     declarative_subtyping_distor A C
 | DSO_top : forall (A:typ),
     declarative_subtyping_distor A t_top
 | DSO_bot : forall (A:typ),
     declarative_subtyping_distor t_bot A
 | DSO_arrow : forall (A C B D:typ),
     declarative_subtyping_distor B A ->
     declarative_subtyping_distor C D ->
     declarative_subtyping_distor (t_arrow A C) (t_arrow B D)
 | DSO_and : forall (A B C:typ),
     declarative_subtyping_distor A B ->
     declarative_subtyping_distor A C ->
     declarative_subtyping_distor A (t_and B C)
 | DSO_andl : forall (A B:typ),
     declarative_subtyping_distor (t_and A B) A
 | DSO_andr : forall (A B:typ),
     declarative_subtyping_distor (t_and A B) B
 | DSO_or : forall (A B C:typ),
     declarative_subtyping_distor A C ->
     declarative_subtyping_distor B C ->
     declarative_subtyping_distor (t_or A B) C
 | DSO_orl : forall (A B:typ),
     declarative_subtyping_distor A (t_or A B)
 | DSO_orr : forall (B A:typ),
     declarative_subtyping_distor B (t_or A B)
 | DSO_distArr : forall (A B1 B2:typ),
     declarative_subtyping_distor (t_and  (t_arrow A B1)   (t_arrow A B2) ) (t_arrow A (t_and B1 B2))
 | DSO_distArrRev : forall (A B1 B2:typ),
     declarative_subtyping_distor (t_arrow A (t_and B1 B2)) (t_and  (t_arrow A B1)   (t_arrow A B2) )
 | DSO_distArrU : forall (A1 B A2:typ),
     declarative_subtyping_distor (t_and  (t_arrow A1 B)   (t_arrow A2 B) ) (t_arrow (t_or A1 A2) B)
 | DSO_distArrURev : forall (A1 A2 B:typ),
     declarative_subtyping_distor (t_arrow (t_or A1 A2) B) (t_and  (t_arrow A1 B)   (t_arrow A2 B) )
 | DSO_distOr : forall (A1 B A2:typ),
     declarative_subtyping_distor (t_and  (t_or A1 B)   (t_or A2 B) ) (t_or  (t_and A1 A2)  B).

(* This is disjunctive ordinary types defined in Fig. 5 *)
Inductive single_ord : typ -> Prop :=    (* w.r.t intersection types *)
 | SO_top :
     single_ord t_top
 | SO_bot :
     single_ord t_bot
 | SO_int :
     single_ord t_int
 | SO_arrow : forall (A B:typ),
     ordu A ->
     single_ord B ->
     single_ord (t_arrow A B)
 | SO_or : forall (A B:typ),
     single_ord A ->
     single_ord B ->
     single_ord (t_or A B)
(* This is conjunctive ordinary types defined in Fig. 5 *)
with ordu : typ -> Prop :=    (* w.r.t union types *)
 | OU_top :
     ordu t_top
 | OU_bot :
     ordu t_bot
 | OU_int :
     ordu t_int
 | OU_arrow : forall (A B:typ),
     ordu (t_arrow A B)
 | OU_and : forall (A B:typ),
     ordu A ->
     ordu B ->
     ordu (t_and A B).

(* This is disjunctive splittable types defined in Fig. 5 *)
Inductive single_spl : typ -> typ -> typ -> Prop:=(* w.r.t intersection types *)
 | SSp_and : forall (A B:typ),
     single_spl (t_and A B) A B
 | SSp_arrow : forall (A B C D:typ),
     single_spl B C D ->
     single_spl (t_arrow A B) (t_arrow A C) (t_arrow A D)
 | SSp_arrowUnion : forall (A D B C:typ),
     single_ord D ->
     splu A B C ->
     single_spl (t_arrow A D) (t_arrow B D) (t_arrow C D)
 | SSp_orl : forall (A B A1 A2:typ),
     single_spl A A1 A2 ->
     single_spl (t_or A B) (t_or A1 B) (t_or A2 B)
 | SSp_orr : forall (A B B1 B2:typ),
     single_ord A ->
     single_spl B B1 B2 ->
     single_spl (t_or A B) (t_or A B1) (t_or A B2)
(* This is conjunctive splittable types defined in Fig. 5 *)
with splu : typ -> typ -> typ -> Prop :=  (* w.r.t union types *)
 | SpU_or : forall (A B:typ),
     splu (t_or A B) A B
 | SpU_andl : forall (A B A1 A2:typ),
     splu A A1 A2 ->
     splu (t_and A B) (t_and A1 B) (t_and A2 B)
 | SpU_andr : forall (A B B1 B2:typ),
     ordu A ->
     splu B B1 B2 ->
     splu (t_and A B) (t_and A B1) (t_and A B2).

(* This is algorithmic subtyping defined in Fig. 6 *)
Inductive singlemode_sub : typ -> typ -> Prop :=
 | SS_int :
     singlemode_sub t_int t_int
 | SS_top : forall (A:typ),
     singlemode_sub A t_top
 | SS_bot : forall (A:typ),
     singlemode_sub t_bot A
 | SS_arrow : forall (A1 A2 B1 B2:typ),
     single_ord (t_arrow A1 A2) ->
     single_ord (t_arrow B1 B2) ->
     singlemode_sub B1 A1 ->
     singlemode_sub A2 B2 ->
     singlemode_sub (t_arrow A1 A2) (t_arrow B1 B2)
 | SS_and : forall (A B B1 B2:typ),
     single_spl B B1 B2 ->
     singlemode_sub A B1 ->
     singlemode_sub A B2 ->
     singlemode_sub A B
 | SS_andl : forall (A B A1 A2:typ),
     single_ord B ->
     single_spl A A1 A2 ->
     singlemode_sub A1 B ->
     singlemode_sub A B
 | SS_andr : forall (A B A1 A2:typ),
     single_ord B ->
     single_spl A A1 A2 ->
     singlemode_sub A2 B ->
     singlemode_sub A B
 | SS_or : forall (A B A1 A2:typ),
     single_ord A ->
     single_ord B ->
     splu A A1 A2 ->
     singlemode_sub A1 B ->
     singlemode_sub A2 B ->
     singlemode_sub A B
 | SS_orl : forall (A B B1 B2:typ),
     single_ord A ->
     single_ord B ->
     ordu A ->
     splu B B1 B2 ->
     singlemode_sub A B1 ->
     singlemode_sub A B
 | SS_orr : forall (A B B1 B2:typ),
     single_ord A ->
     single_ord B ->
     ordu A ->
     splu B B1 B2 ->
     singlemode_sub A B2 ->
     singlemode_sub A B.

(* This is the declarative duotyping defined in Fig. 7 *)
Inductive osub : typ -> mode -> typ -> Prop :=
 | OS_refl : forall (A:typ) (mode5:mode),
     osub A mode5 A
 | OS_trans : forall (A:typ) (mode5:mode) (C B:typ),
     osub A mode5 B ->
     osub B mode5 C ->
     osub A mode5 C
 | OS_top : forall (A:typ) (mode5:mode),
     osub A mode5  (typbymode mode5 )
 | OS_arr : forall (A C:typ) (mode5:mode) (B D:typ),
     osub A  (flipmode  mode5 )  B ->
     osub C mode5 D ->
     osub (t_arrow A C) mode5 (t_arrow B D)
 | OS_and : forall (A:typ) (mode5:mode) (B C:typ),
     osub A mode5 B ->
     osub A mode5 C ->
     osub A mode5  (choose mode5 B C )
 | OS_andl : forall (A:typ) (mode5:mode) (B:typ),
     osub  (choose mode5 A B )  mode5 A
 | OS_andr : forall (A:typ) (mode5:mode) (B:typ),
     osub  (choose mode5 A B )  mode5 B
 | OS_distArr : forall (A B C:typ) (mode5:mode),
     osub (t_and  (t_arrow A B)   (t_arrow A C) ) mode5 (t_arrow A (t_and B C))
 | OS_distArrU : forall (A C B:typ) (mode5:mode),
     osub (t_and  (t_arrow A C)   (t_arrow B C) ) mode5 (t_arrow (t_or A B) C)
 | OS_distOr : forall (A1:typ) (mode5:mode) (B A2:typ),
     osub  (choose mode5  (choose  (flipmode  mode5 )  A1 B )   (choose  (flipmode  mode5 )  A2 B )  )  mode5  (choose  (flipmode  mode5 )   (choose mode5 A1 A2 )  B )
 | OS_flip : forall (A:typ) (mode5:mode) (B:typ),
     osub B  (flipmode  mode5 )  A ->
     osub A mode5 B.

(* This is the ordinary types defined in Fig. 8 *)
Inductive ord : mode -> typ -> Prop :=    (* parameterized by mode *)
 | O_top : forall (m:mode),
     ord m t_top
 | O_bot : forall (m:mode),
     ord m t_bot
 | O_int : forall (m:mode),
     ord m t_int
 | O_arrowUnion : forall (A B:typ),
     ord m_super (t_arrow A B)
 | O_arrow : forall (A B:typ),
     ord m_super A ->
     ord m_sub B ->
     ord m_sub (t_arrow A B)
 | O_or : forall (m:mode) (A B:typ),
     ord m A ->
     ord m B ->
     ord m  (choose  (flipmode  m )  A B ) .

(* This is the splittable types defined in Fig. 8 *)
Inductive spl : mode -> typ -> typ -> typ -> Prop := (* parameterized by mode *)
 | Sp_and : forall (m:mode) (A B:typ),
     spl m  (choose m A B )  A B
 | Sp_arrow : forall (A B C D:typ),
     spl m_sub B C D ->
     spl m_sub (t_arrow A B) (t_arrow A C) (t_arrow A D)
 | Sp_arrowUnion : forall (A D B C:typ),
     ord m_sub D ->
     spl m_super A B C ->
     spl m_sub (t_arrow A D) (t_arrow B D) (t_arrow C D)
 | Sp_orl : forall (m:mode) (A B A1 A2:typ),
     spl m A A1 A2 ->
     spl m  (choose  (flipmode  m )  A B )   (choose  (flipmode  m )  A1 B )   (choose  (flipmode  m )  A2 B )
 | Sp_orr : forall (m:mode) (A B B1 B2:typ),
     ord m A ->
     spl m B B1 B2 ->
     spl m  (choose  (flipmode  m )  A B )   (choose  (flipmode  m )  A B1 )   (choose  (flipmode  m )  A B2 ) .

(* This is the algorithmic duotyping defined in Fig. 8 *)
Inductive duo : typ -> mode -> typ -> Prop :=
 | SD_int : forall (mode5:mode),
     duo t_int mode5 t_int
 | SD_top : forall (A:typ) (mode5:mode),
     duo A mode5  (typbymode mode5 )
 | SD_and : forall (A:typ) (mode5:mode) (B B1 B2:typ),
     spl mode5 B B1 B2 ->
     duo A mode5 B1 ->
     duo A mode5 B2 ->
     duo A mode5 B
 | SD_andl : forall (A:typ) (mode5:mode) (B A1 A2:typ),
     ord mode5 B ->
     spl mode5 A A1 A2 ->
     duo A1 mode5 B ->
     duo A mode5 B
 | SD_andr : forall (A:typ) (mode5:mode) (B A1 A2:typ),
     ord mode5 B ->
     spl mode5 A A1 A2 ->
     duo A2 mode5 B ->
     duo A mode5 B
 | SD_dual : forall (A:typ) (mode5:mode) (B:typ),
     ord mode5 A ->
     ord mode5 B ->
     duo B  (flipmode  mode5 )  A ->
     duo A mode5 B
 | SD_arr : forall (A1 A2:typ) (mode5:mode) (B1 B2:typ),
     ord m_sub (t_arrow A1 A2) ->
     ord m_sub (t_arrow B1 B2) ->
     duo A1  (flipmode  mode5 )  B1 ->
     duo A2 mode5 B2 ->
     duo (t_arrow A1 A2) mode5 (t_arrow B1 B2).

(* This is the algorithmic duotyping with no dual rule D-dual.
   Some rules come with its dual *)
Inductive sub : typ -> mode -> typ -> Prop :=
 | S_int : forall (mode5:mode),
     sub t_int mode5 t_int
 | S_top : forall (A:typ) (mode5:mode),
     sub A mode5  (typbymode mode5 )
 | S_bot : forall (mode5:mode) (A:typ),
     sub  (typbymode  (flipmode  mode5 )  )  mode5 A
 | S_arr : forall (A1 A2:typ) (mode5:mode) (B1 B2:typ),
     ord m_sub (t_arrow A1 A2) ->
     ord m_sub (t_arrow B1 B2) ->
     sub A1  (flipmode  mode5 )  B1 ->
     sub A2 mode5 B2 ->
     sub (t_arrow A1 A2) mode5 (t_arrow B1 B2)
 | S_and : forall (A:typ) (mode5:mode) (B B1 B2:typ),
     spl mode5 B B1 B2 ->
     sub A mode5 B1 ->
     sub A mode5 B2 ->
     sub A mode5 B
 | S_andl : forall (A:typ) (mode5:mode) (B A1 A2:typ),
     ord mode5 B ->
     spl mode5 A A1 A2 ->
     sub A1 mode5 B ->
     sub A mode5 B
 | S_andr : forall (A:typ) (mode5:mode) (B A1 A2:typ),
     ord mode5 B ->
     spl mode5 A A1 A2 ->
     sub A2 mode5 B ->
     sub A mode5 B
 | S_or : forall (A:typ) (mode5:mode) (B A1 A2:typ),
     ord mode5 A ->
     ord mode5 B ->
     spl  (flipmode  mode5 )  A A1 A2 ->
     sub A1 mode5 B ->
     sub A2 mode5 B ->
     sub A mode5 B
 | S_orl : forall (A:typ) (mode5:mode) (B B1 B2:typ),
     ord mode5 A ->
     ord mode5 B ->
     ord  (flipmode  mode5 )  A ->
     spl  (flipmode  mode5 )  B B1 B2 ->
     sub A mode5 B1 ->
     sub A mode5 B
 | S_orr : forall (A:typ) (mode5:mode) (B B1 B2:typ),
     ord mode5 A ->
     ord mode5 B ->
     ord  (flipmode  mode5 )  A ->
     spl  (flipmode  mode5 )  B B1 B2 ->
     sub A mode5 B2 ->
     sub A mode5 B.

(* This is the algorithmic duotyping with no dual rule D-dual and
   no ordinary-type condition *)
Inductive lsub : typ -> mode -> typ -> Prop :=
 | LS_int : forall (mode5:mode),
     lsub t_int mode5 t_int
 | LS_top : forall (A:typ) (mode5:mode),
     lsub A mode5  (typbymode mode5 )
 | LS_bot : forall (mode5:mode) (A:typ),
     lsub  (typbymode  (flipmode  mode5 )  )  mode5 A
 | LS_arr : forall (A1 A2:typ) (mode5:mode) (B1 B2:typ),
     lsub A1  (flipmode  mode5 )  B1 ->
     lsub A2 mode5 B2 ->
     lsub (t_arrow A1 A2) mode5 (t_arrow B1 B2)
 | LS_and : forall (A:typ) (mode5:mode) (B B1 B2:typ),
     spl mode5 B B1 B2 ->
     lsub A mode5 B1 ->
     lsub A mode5 B2 ->
     lsub A mode5 B
 | LS_andl : forall (A:typ) (mode5:mode) (B A1 A2:typ),
     spl mode5 A A1 A2 ->
     lsub A1 mode5 B ->
     lsub A mode5 B
 | LS_andr : forall (A:typ) (mode5:mode) (B A1 A2:typ),
     spl mode5 A A1 A2 ->
     lsub A2 mode5 B ->
     lsub A mode5 B
 | LS_or : forall (A:typ) (mode5:mode) (B A1 A2:typ),
     spl  (flipmode  mode5 )  A A1 A2 ->
     lsub A1 mode5 B ->
     lsub A2 mode5 B ->
     lsub A mode5 B
 | LS_orl : forall (A:typ) (mode5:mode) (B B1 B2:typ),
     spl  (flipmode  mode5 )  B B1 B2 ->
     lsub A mode5 B1 ->
     lsub A mode5 B
 | LS_orr : forall (A:typ) (mode5:mode) (B B1 B2:typ),
     spl  (flipmode  mode5 )  B B1 B2 ->
     lsub A mode5 B2 ->
     lsub A mode5 B.


Definition True' : Prop := forall P : Prop, P -> P.
Goal True <-> True'.
Proof.
  unfold iff, True'.
  split.
  intros.
  assumption.
  intro.
  apply I.
Qed.
Goal True'.
Proof.
  unfold True'.
  intros.
  assumption.
Qed.

Definition False' : Prop := forall P : Prop, P.
Goal False' <-> False.
Proof.
  unfold iff.
  split.
  intro.
  apply H.
  apply False_ind.
Qed.
Goal forall P : Prop, False' -> P.
Proof.
  intros.
  apply H.
Qed.

Definition and' : Prop -> Prop -> Prop :=
  fun A B => forall P : Prop, (A -> B -> P) -> P.
Goal forall P Q : Prop, P /\ Q <-> and' P Q.
Proof.
  intros.
  unfold iff, and'.
  split.
  intro.
  destruct H.
  intros.
  exact (H1 H H0).
  intro.
  split.
  apply H.
  intros.
  assumption.
  apply H.
  intros.
  assumption.
Qed.

Definition or' : Prop -> Prop -> Prop :=
  fun A B => forall P : Prop, (A -> P) -> (B -> P) -> P.
Goal forall P Q : Prop, P \/ Q <-> or' P Q.
Proof.
  intros.
  unfold iff, or'.
  split.
  intros.
  destruct H.
  exact (H0 H).
  exact (H1 H).
  intro.
  apply H.
  apply or_introl.
  apply or_intror.
Qed.


Require Import HoTT.

Definition push_sigma {A B: Type} (P: A -> Type) (f: A -> B): B -> Type
  := fun b: B => { a: A | P a & f a = b}.

Definition push_prod {A B: Type} (P: A -> Type) (f: A -> B): B -> Type
  := fun b: B => forall a: A, (f a = b) -> P a.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Epsilon operator                                                        *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibRelation.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Definition and specification of Hilbert's epsilon operator *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of epsilon *)

(** [epsilon P] where [P] is a predicate over an inhabited type [A],
    returns a value [x] of type [A] that satisfies [P], if there exists
    one such value, else it returns an arbitrary value of type [A]. *)

Definition epsilon_def : forall A {IA:Inhab A} (P:A->Prop),
  { x : A | (exists y, P y) -> P x }.
Proof using.
  intros A IA P. destruct (classicT (exists y, P y)) as [H|H].
  { apply indefinite_description. destruct H as [x H].
    exists x. intros _. apply H. }
  { exists (@arbitrary A IA). intros N. false H. apply N. }
Qed.

Definition epsilon A {IA: Inhab A} (P:A->Prop) : A :=
  sig_val (epsilon_def P).

Lemma pred_epsilon : forall A {IA:Inhab A} (P:A->Prop),
  (exists x, P x) ->
  P (epsilon P).
Proof using. intros. apply~ (sig_proof (epsilon_def P)). Qed.

Opaque epsilon.

(* Remark: the proof term associated with the definition *)

Definition epsilon_def' A {IA:Inhab A} (P:A->Prop) :
  { x : A | (exists y, P y) -> P x } :=
  match classicT (exists y, P y) with
  | left H =>
      indefinite_description
        (let (x,H0) := H in
         ex_intro (fun x0 => (exists y, P y) -> P x0)
                   x
                  (fun N => H0))
  | right H =>
      exist (fun x => (exists y, P y) -> P x)
            arbitrary
            (fun N => False_ind (P arbitrary) (H N))
  end.

(* ---------------------------------------------------------------------- *)
(** ** Lemmas about epsilon *)

Lemma pred_epsilon_weaken : forall A {IA:Inhab A} (P Q : A->Prop),
  (exists x, P x) ->
  (forall x, P x -> Q x) ->
  Q (epsilon P).
Proof using. introv E M. apply M. apply* pred_epsilon. Qed.

Lemma pred_epsilon_of_val : forall A (x:A) (P:A->Prop) {IA:Inhab A},
  P x ->
  P (epsilon P).
Proof using. intros. apply* pred_epsilon. Qed.

Lemma pred_epsilon_of_val_weaken : forall A (x:A) (P Q:A->Prop) {IA:Inhab A},
  P x ->
  (forall x, P x -> Q x) ->
  Q (epsilon P).
Proof using. introv Px W. apply W. apply* pred_epsilon. Qed.

Lemma epsilon_eq : forall A {IA:Inhab A} (P Q:A->Prop),
  (forall x, P x <-> Q x) ->
  epsilon P = epsilon Q.
Proof using. introv H. fequals. extens*. Qed.

(* ---------------------------------------------------------------------- *)
(** ** (Private) tactic [epsilon_find] *)

(** [epsilon_find cont] locates an expression of the form [epsilon P]
    in the goal and invokes the continuation [cont] on [P].

    [epsilon_find_in H cont] is similar but looks for the expression
    only in the hypothesis named [H]. *)

Ltac epsilon_find cont :=
  match goal with
  | |- context [epsilon ?P] => cont P
  | H: context [epsilon ?P] |- _ => cont P
  end.

Ltac epsilon_find_in H cont :=
  match type of H with context [epsilon ?P] => cont P end.

(* ---------------------------------------------------------------------- *)
(** ** Tactics [epsilon_name] *)

(** [epsilon_name X] assigns a name [X] to an expression of the
    form [epsilon P] that appears in the goal or an hypothesis,
    by calling [set (X := epsilon P)].

    [epsilon_name X in H] assignes a name [X] to an expression of the
    form [epsilon P] that appears in hypothesis [H]. *)

Ltac epsilon_name_core X :=
  epsilon_find ltac:(fun P => sets X: (epsilon P)).

Ltac epsilon_name_in_core X H :=
  epsilon_find_in H ltac:(fun P => sets X: (epsilon P)).

Tactic Notation "epsilon_name" ident(X) :=
  epsilon_name_core X.

Tactic Notation "epsilon_name" ident(X) "in" hyp(H)  :=
  epsilon_name_in_core X H.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to work with [epsilon] *)

(** [epsilon X] locates an expression of the form [epsilon P] in the goal,
    names [X] this expression (like [epsilon_name X]), then produces
    a subgoal [exists x, P x], and leaves at the head of the main goal
    an hypothesis [P X].

    [epsilon X in H] is similar, but looks for [epsilon P] only in
    hypothesis [H]. *)

Lemma pred_epsilon' : forall A (P:A->Prop) (IA:Inhab A),
  (exists x, P x) ->
  P (epsilon P).
Proof using. intros. applys* pred_epsilon. Qed.

Ltac epsilon_cont X P :=
  let I := fresh "H" X in
  lets I: (>> (@pred_epsilon' _ P) __ __);
    [ | sets X: (epsilon P); revert I ].

Ltac epsilon_core X :=
  epsilon_find ltac:(fun P => epsilon_cont X P).

Ltac epsilon_in_core X H :=
  epsilon_find_in H ltac:(fun P => epsilon_cont X P).

Tactic Notation "epsilon" ident(X) :=
  epsilon_core X.
Tactic Notation "epsilon" ident(X) "in" hyp(H) :=
  epsilon_in_core X H.

Tactic Notation "epsilon" "~" ident(X) :=
  epsilon X; auto_tilde.
Tactic Notation "epsilon" "~" ident(X) "in" hyp(H) :=
  epsilon X in H; auto_tilde.

Tactic Notation "epsilon" "*" ident(X) :=
  epsilon X; auto_star.
Tactic Notation "epsilon" "*" ident(X) "in" hyp(H) :=
  epsilon X in H; auto_star.

(* ********************************************************************** *)
(** * Construction of a function from a relation, using [epsilon] *)

(* Given a relation [R] of type [A->B->Prop], [rel_to_fun R] returns a
   function [f] of type [A->B] that satisfies the relation [R], i.e.
   such that [R x (f x)] forall [x] that has an image by [R]. *)

Definition rel_to_fun A `{IB:Inhab B} (R:A->B->Prop) : A -> B :=
  fun (a:A) => epsilon (fun b => R a b).

Section Rel_to_fun.
Context (A B : Type) {IB:Inhab B}.
Implicit Types R : A -> B -> Prop.

(* Every [a] in the domain of [R] is related by [R] with [rel_to_fun a]. *)

Lemma rel_rel_to_fun_of_exists : forall R a,
  (exists b, R a b) ->
  R a (rel_to_fun R a).
Proof using IB. introv [x H]. unfold rel_to_fun. epsilon* y. Qed.

Lemma rel_rel_to_fun_of_rel : forall R a b,
  R a b ->
  R a (rel_to_fun R a).
Proof using IB. intros. applys* rel_rel_to_fun_of_exists. Qed.

Lemma rel_rel_to_fun_of_not_forall : forall R a,
  ~ (forall b, ~ R a b) ->
  R a (rel_to_fun R a).
Proof using IB.
  introv. rew_logic. intros [x H]. applys* rel_rel_to_fun_of_exists.
Qed.

Lemma rel_in_fun_rel_to_fun : forall R,
  functional R ->
  rel_in_fun R (rel_to_fun R).
Proof using IB. unfold rel_in_fun, rel_to_fun. introv M H. epsilon* z. Qed.

(** Reformulation of above *)

Lemma rel_to_fun_eq_of_functional : forall x y R,
  functional R ->
  R x y ->
  rel_to_fun R x = y.
Proof using IB. introv M E. applys* rel_in_fun_rel_to_fun. Qed.

End Rel_to_fun.

(* Remark: in the special case where [R] has type [A->A->Prop],
   one may get away without providing a proof of [Inhab A].

  Definition rel_to_fun' A (R : A -> A -> Prop) (a : A) : A :=
    @rel_to_fun A A (Inhab_of_val a) R a.
*)