(** Let's build a provably correct (but very simple) compiler! We'll see
    that with the right tactic automation, the proof can be extremely simple.
   This example is taken from the [Library StackMachine] chapter of CPDT.

##
   You'll need the tarball of open-source libraries from CPDT, which can be
   obtained from Adam Chlipala's website:
##
      [http://adam.chlipala.net/cpdt/cpdtlib.tgz]
##

   You will need to compile the source, which can be done as follows in
   the cpdtlib:
#
#
      coqc -R . Cpdt *.v
#
#

   To make the compiled CPDT libraries automatically available from
   within Emacs, put this text into .dir-locals.el:
#
#
      ((coq-mode . ((coq-prog-args . ("-emacs-U" "-I" "../cpdtlib")))))
#
#

   From coqide, you can use the -R command:
#
#
      coqc -R <cpdtlib> Cpdt lecture4.v
#
#

   where [<cpdtlib>] is the full pathname of the cpdtlib directory.
##
*)

Require Import Bool Arith List CpdtTactics.
Require Import Unicode.Utf8.

(** This command tells Coq to automatically make some arguments implicit when
   you write definitions.  In general, it will make implicit something that
   it can easily figure out from the other arguments (e.g., types often)
   and saves you from using curly braces and so forth.  Figuring out what
   it decides to make implicit isn't always easy.  When you Print a definition,
   it tells you what arguments are implicit, so that helps.  You get used
   to what it decides pretty quickly... *)
Set Implicit Arguments.

(** Let's start by defining some syntax for a simple
    language of arithmetic expressions. This is just
    an abstract syntax tree -- not a computation but
    a data structure representing one.
  *)
Inductive binop : Type := Plus | Times.
Check binop.
Check Plus.
Inductive ternop: Type := If.

Inductive exp : Type :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp
| Ternop: ternop -> exp -> exp -> exp -> exp.

(** Using Coq, we can describe the _meaning_ of the computation
    denoted by an abstract syntax tree. We can think of this
    as giving a mathematical description of the computation
    (or as a compilation directly into Coq).
*)
Definition binopDenote (b:binop) : nat -> nat -> nat :=
  match b with
    | Plus => plus
    | Times => mult
  end.

Print eq.
Print le.

Definition ternopDenote (b:ternop) : nat -> nat -> nat -> nat :=
  match b with
    | If => fun (e1 e2 e3 : nat) => match e1 with
                      | 0 => e2
                      | S n => e3
                    end
  end.

Eval compute in ternopDenote If 3 4 5.

Fixpoint expDenote (e:exp) : nat :=
  match e with
    | Const n => n
    | Binop b e1 e2 => (binopDenote b) (expDenote e1) (expDenote e2)
    | Ternop b e1 e2 e3 => (ternopDenote b) (expDenote e1) (expDenote e2)(expDenote e3)
  end.

(** Now let's define a stack-machine target language for a
    compiler. A program is a list of instructions that
    manipulate a stack of operands.
  *)

Inductive instr : Type :=
| iConst : nat -> instr
| iBinop : binop -> instr
| iTernop: ternop -> instr.

Definition prog := list instr.
Definition stack := list nat.

(** We can also give a denotation for stack machine programs,
    in terms of the output stack. However, not all stack machine programs make sense, since
    there might not be enough arguments on the stack for a
    binary operator. We give these programs the denotation None.
  *)

Definition instrDenote (i:instr) (s:stack) : option stack :=
  match i with
    | iConst n => Some (n::s)
    | iBinop b =>
      match s with
        | arg1 :: arg2 :: s' => Some ((binopDenote b) arg1 arg2::s')
        | _ => None
      end
    | iTernop b =>
      match s with
        | arg1 :: arg2 :: arg3 :: s' => Some ((ternopDenote b) arg1 arg2 arg3 :: s')
        | _ => None
end
  end.

Fixpoint progDenote (p:prog) (s:stack) : option stack :=
  match p with
    | nil => Some s
    | i::p' =>
      match instrDenote i s with
        | None => None
        | Some s' => progDenote p' s'
      end
  end.

Eval compute in progDenote (iConst 3::iConst 4::iBinop Times::nil) nil.
Import ListNotations.
Eval compute in progDenote [iConst 3; iConst 4; iBinop Times] [].
Eval compute in progDenote [iConst 3; iConst 4; iConst 5; iTernop If] [].

(** Now let's write a compiler from the source language
    to the argument language! *)

Fixpoint compile (e:exp) : prog :=
  match e with
    | Const n => [iConst n]
    | Binop b e1 e2 => compile e2 ++ compile e1 ++ iBinop b :: nil
    | Ternop b e1 e2 e3 => compile e3 ++ compile e2 ++ compile e1 ++ iTernop b :: nil
  end.

(** Wouldn't it be great if our compiler were correct? We can
    prove that by relating the denotations of the source program
    and its compilation. *)

Lemma compile_correct'' : forall e p s,
    progDenote (compile e ++ p) s = progDenote p (expDenote e::s).
  Proof.
    induction e.
    - simpl. reflexivity.
    - simpl. intros. repeat rewrite <- app_assoc. rewrite IHe2. rewrite IHe1. simpl. reflexivity.
    - simpl. intros. repeat rewrite <- app_assoc. rewrite IHe3. rewrite IHe2. rewrite IHe1. simpl. reflexivity.
  Qed.

Lemma compile_correct' : forall e p s,
    progDenote (compile e ++ p) s = progDenote p (expDenote e::s).
  Proof.
    (** [crush] is a magic tactic provided by [CPDT] that manages to knock off
       a lot of obligations for us.  Later, we will look at how [crush] is
       defined to build our own proof-automation.  But in some sense, this is
       the ideal proof in a readability-sense.  It's the equivalent of writing
       "by induction on e".  *)
    induction e ; crush.
    Qed.

Theorem compile_correct : forall e, progDenote (compile e) nil = Some (expDenote e :: nil).
Proof.

  (** And now we can use this lemma to prove our desired theorem. *)
  intros.
  rewrite (app_nil_end (compile e)).
  rewrite compile_correct'.
  reflexivity.
Qed.

(***** Second example ******)

Inductive type : Set := Nat | Bool.

(** Notice that both [tbinop] and [texp] are *indexed* by [type]s.  That is
   to say, we are reflecting some structure in the types of the constructors.

   For example, in the case of [TBinop], we are requiring that we pass in
   a [binop] indexed by [t1], [t2], and [t], and that the sub-expressions
   were built from constructors that are indexed by [t1] and [t2] respectively,
   and we get out a [texp] indexed by [t].

   GHC and OCaml provide support for this kind of indexed data type now,
   though it's called "generalized abstract data types" (GADTs) in those
   contexts.  Coq (and type theory) have had them for a long time...
*)
Inductive tbinop : type -> type -> type -> Type :=
| TPlus  : tbinop Nat Nat Nat
| TTimes : tbinop Nat Nat Nat
| TEq    : forall t, tbinop t t Bool
| TLt    : tbinop Nat Nat Bool.

Inductive texp : type -> Type :=
| TNConst : nat -> texp Nat
| TBConst : bool -> texp Bool
| TBinop : forall (t1 t2 t:type), tbinop t1 t2 t -> texp t1 ->
                                  texp t2 -> texp t.

(** This is a kind of a funny function -- it's mapping our names for
   types, [Nat] and [Bool], to actual Coq types.  This is not something
   you can write in Ocaml or Coq.
*)
Definition typeDenote (t : type) : Type :=
  match t with
    | Nat => nat
    | Bool => bool
  end.

(** Look carefully at the type of [tbinopDenote] and see how this
   matches up with the definition. *)
Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b with
    | TPlus => plus
    | TTimes => mult
    | TEq Nat => beq_nat
    | TEq Bool => eqb
    | TLt => leb
  end.

Check tbinopDenote.
Check TBinop.

(** Similarly, here we can see that [texpDenote] takes an [texp] indexed
   by a [type] named [t], and returns a value of the Coq type [typeDenote t].
   It's the ability to (a) use dependent types, (b) write functions from
   values to types, (c) index data constructor types with other data that
   really provides the power to capture this here.

   In essence, we are proving that our compiler preserves types appropriately
   when we use this kind of indexing.  And it's all happening more or less
   for free.
*)
Fixpoint texpDenote (t:type) (e : texp t) : typeDenote t :=
  match e with
    | TNConst n => n
    | TBConst b => b
    | TBinop b e1 e2 => (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.

Definition tstack := list type.

(** A tinstr describes how one stack (at the type level) is mapped
    to another stack by a single instruction. *)
Inductive tinstr : tstack -> tstack -> Type :=
| TiNConst : forall s, nat -> tinstr s (Nat :: s)
| TiBConst : forall s, bool -> tinstr s (Bool :: s)
| TiBinop : forall arg1 arg2 res s,
  tbinop arg1 arg2 res
  -> tinstr (arg1 :: arg2 :: s) (res :: s).

(** The action of an entire program is a tprog. *)
Inductive tprog : tstack -> tstack -> Type :=
| TNil : forall s, tprog s s
| TCons : forall s1 s2 s3,
  tinstr s1 s2
  -> tprog s2 s3
  -> tprog s1 s3.

(** vstack maps a tstack into a tuple containing the
    denotations of all the types in the stack *)
Fixpoint vstack (ts : tstack) : Type :=
  match ts with
    | nil => unit
    | t :: ts' => (typeDenote t) * (vstack ts')
  end%type.

(** We can lift the action of an instruction to
    a mapping over real types.
 *)
Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
    | TiNConst _ n => fun s => (n, s)
    | TiBConst _ b => fun s => (b, s)
    | TiBinop  _ b => fun s =>
      let '(arg1, (arg2, s')) := s in
        ((tbinopDenote b) arg1 arg2, s')
  end.

(** Then, concatenating with a program or instruction is just composition of the denotations. *)
Fixpoint tprogDenote ts ts' (p : tprog ts ts') : vstack ts -> vstack ts' :=
  match p with
    | TNil _ => fun s => s
    | TCons i p' => fun s => tprogDenote p' (tinstrDenote i s)
  end.

Fixpoint tconcat ts ts' ts'' (p : tprog ts ts') : tprog ts' ts'' -> tprog ts ts'' :=
  match p with
    | TNil _ => fun p' => p'
    | TCons i p1 => fun p' => TCons i (tconcat p1 p')
  end.

Require Import Coq.Logic.FunctionalExtensionality.

Fixpoint tcompile t (e : texp t) (ts : tstack) : tprog ts (t :: ts) :=
  match e with
    | TNConst n => TCons (TiNConst _ n) (TNil _)
    | TBConst b => TCons (TiBConst _ b) (TNil _)
    | TBinop b e1 e2 => (tconcat (tcompile e2 _)
                        (tconcat (tcompile e1 _)
                                 (TCons (TiBinop _ b) (TNil _))))
  end.

Lemma tconcat_correct : forall ts ts' ts''
  (p : tprog ts ts') (p' : tprog ts' ts'') (s : vstack ts),
  tprogDenote (tconcat p p') s = tprogDenote p' ( tprogDenote p s).
Proof.
  induction p; crush.
Qed.

(** A [Hint] is a way of registering a definition, such as [tconcat_correct],
   as something we want to use within certain tactics, such as [crush] or
   [auto].  Effectively, by registering [tconcat_correct] as a [Hint Rewrite],
   we are telling [crush] (and [auto]) that it should try to rewrite the
   goal using this lemma as part of the search for a proof.

   Adding hints is a great way to get more powerful tactics.  But it does
   have a downside in that it can blow up the time it takes for a tactic to
   find a proof.  So we will see some techniques for using hints in a more
   modular fashion.
*)
Hint Rewrite tconcat_correct.

Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
  tprogDenote (tcompile e ts) s = (texpDenote e, s).
Proof.
  induction e; crush.
Qed.
Hint Rewrite tcompile_correct'.

Theorem tcompile_correct : forall t (e : texp t),
  tprogDenote (tcompile e nil) tt = (texpDenote e, tt).
  crush.
Qed.

Print tcompile_correct'.
(** [Extraction] and [Recursive Extraction] allow us to extract OCaml
   code from a Coq development.  We can also extract Haskell or Scheme.
   Look carefully at the extracted code and compare with the Coq
   definitions. *)
Recursive Extraction tcompile.


Require Import Reals.
Require Import Gappa_tactic.

Goal
  forall a1 a2 b1 b2 : R,
  (Rabs (a1 - a2) <= 1/16 * Rabs a2)%R ->
  (Rabs (b1 - b2) <= 1/16 * Rabs b2)%R ->
  (Rabs (a1 * b1 - a2 * b2) <= 33/256 * Rabs (a2 * b2))%R.
Proof.
gappa.
Qed.


Inductive Maybe : Set -> Set :=
| None : forall A, Maybe A
| Just : forall A, A -> Maybe A.

Inductive Ty : Set :=
| Arr : Ty -> Ty -> Ty.

Inductive Term : Set :=
| v : nat -> Term
| lam : Ty -> Term -> Term
| app : Term -> Term -> Term.

Fixpoint shiftat (d : nat) (x : Term) {struct x} : Term :=
  match x with
    | v m => if le_lt_dec d m then v (S m) else v m
    | lam ty t => lam ty (shiftat (S d) t)
    | app r s => app (shiftat d r) (shiftat d s)
  end.

Reserved Notation "G |= t @ ty [n]" (at level 40, no associativity).

Inductive Deriv : Ctx -> Term -> Ty -> Set -> Prop :=
| P : forall G t ty A, G |= t ty A
| Lam : forall A, Deriv G t ty A
| App : forall A, Deriv A -> Deriv A -> Deriv A
where "G |= t @ ty [A]" := (Deriv G t ty A)


Module Lecture1.
  Require Import Arith.
  Require Import List.

  Definition AnIntegerExists : nat := 2.

  Lemma AnIntegerExistsB : nat.
  Proof.
    apply 0.
  Qed.

  Print nat.

  Locate "_ /\ _".
  Check and.
  Print and.

  Definition Proj1 {A B:Prop} : A /\ B -> A :=
    fun (H:A /\ B) =>
      match H with
      | conj x y => x
      end.

  Lemma Proj1B {A B:Prop} : A /\ B -> A.
  Proof.
    intros.
    destruct H.
    apply H.
  Qed.

  Locate "_ <-> _".
  Check iff.
  Print iff.
  Print and.

  Lemma ObjectivismB {A:Prop} : A <-> A.
  Proof.
    split.
    intros.
    apply H.
    intros.
    apply H.
  Qed.

  Lemma ObjectivismB_Semicolons {A:Prop} : A <-> A.
  Proof.
    split; intros; apply H.
  Qed.

  Lemma ObjectivismB_Auto {A:Prop} : A <-> A.
  Proof.
    split; auto.
  Qed.

  Definition Objectivism {A:Prop} : A <-> A :=
    conj (fun x => x) (fun x => x).

  Lemma DistributeAnd {A B C:Prop} :
    A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
  Proof.
    intros.
    destruct H.
    destruct H0.
    left.
    split.
    apply H.
    apply H0.
    right.
    split.
    apply H.
    apply H0.
  Qed.

  Lemma DistributeAnd_Semicolons {A B C:Prop} :
    A /\ (B \/ C) -> (A /\ B) \/ (A /\ C).
  Proof.
    intros.
    destruct H.
    destruct H0;
      (* [X1 | X2 | ... | Xn] applies X1 to the 1st
         subgoal, X2 to the second, and so forth. *)
      [left | right];
      split; try apply H; try apply H0.
  Qed.

End Lecture1.


(* ******************************************************************************* *)
(** * Category of correspondence graphs

    Marco Maggesi
    June 2019
 ********************************************************************************* *)

Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.Combinatorics.CGraph.

Local Open Scope cat.

(** ** Precategory of precgraphs. *)

Definition precgraph_precategory_ob_mor : precategory_ob_mor
  := make_precategory_ob_mor precgraph cgraph_mor.

Definition precgraph_precategory_data : precategory_data
  := make_precategory_data
       precgraph_precategory_ob_mor
       cgraph_mor_id
       (@cgraph_mor_comp).

Lemma is_precategory_precgraph : is_precategory precgraph_precategory_data.
Proof.
  apply is_precategory_one_assoc_to_two.
  apply make_dirprod.
  repeat apply make_dirprod; cbn.
  - exact @cgraph_mor_id_left.
  - exact @cgraph_mor_id_right.
  - apply @cgraph_mor_comp_assoc.
Qed.

Definition precgraph_category : precategory
  := make_precategory
       precgraph_precategory_data
       is_precategory_precgraph.

(** ** Category of cgraphs. *)

Definition cgraph_precategory_ob_mor : precategory_ob_mor
  := make_precategory_ob_mor cgraph cgraph_mor.

Definition cgraph_precategory_data : precategory_data
  := make_precategory_data
       cgraph_precategory_ob_mor
       (λ G : cgraph, cgraph_mor_id G)
       (λ G H K : cgraph, @cgraph_mor_comp G H K).

Lemma is_precategory_cgraph : is_precategory cgraph_precategory_data.
Proof.
  apply is_precategory_one_assoc_to_two.
  repeat apply make_dirprod; cbn.
  - exact @cgraph_mor_id_left.
  - exact @cgraph_mor_id_right.
  - exact @cgraph_mor_comp_assoc.
Qed.

Definition cgraph_precategory : precategory
  := make_precategory
       cgraph_precategory_data
       is_precategory_cgraph.

Lemma has_homsets_graph : has_homsets cgraph_precategory_ob_mor.
Proof.
  intros G H.
  apply isaset_cgraph_mor.
  - exact (isaset_node H).
  - exact (isaset_arc H).
Defined.

Definition cgraph_category : precategory
  := make_precategory
       cgraph_precategory_data
       is_precategory_cgraph.

(** ** Forgetful functor. *)

Definition cgraph_forget_map (G : cgraph) : hSet
  := make_hSet (node G) (isaset_node G).

Definition cgraph_forget_data
  : functor_data cgraph_precategory_ob_mor hset_precategory_ob_mor
  := @make_functor_data
       cgraph_category HSET
       cgraph_forget_map
       (λ G H : cgraph, onnode).

Lemma is_functor_cgraph_forget
  : @is_functor cgraph_precategory hset_precategory cgraph_forget_data.
Proof.
  apply make_dirprod.
  - intro x.
    cbn.
    apply idpath.
  - intros x y z. cbn.
    intros f g.
    apply idpath.
Qed.

Definition cgraph_forget
  : cgraph_category ⟶ HSET
  := @make_functor cgraph_precategory hset_precategory
       cgraph_forget_data
 is_functor_cgraph_forget.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    Lagrange.v

    Proof of Lagrange theorem:
      the oder of a subgroup divides the order of a group

    Definition: lagrange
  **********************************************************************)
Require Import List.
Require Import UList.
Require Import ListAux.
Require Import ZArith Znumtheory.
Require Import NatAux.
Require Import FGroup.

Open Scope Z_scope.

Section Lagrange.

Variable A: Set.

Variable A_dec: forall a b: A, {a = b} + {~ a = b}.

Variable op: A -> A -> A.

Variable G: (FGroup op).

Variable H:(FGroup op).

Hypothesis G_in_H: (incl G.(s)  H.(s)).

(**************************************
   A group and a subgroup have the same neutral element
 **************************************)

Theorem same_e_for_H_and_G: H.(e) = G.(e).
apply trans_equal with (op H.(e) H.(e)); sauto.
apply trans_equal with (op H.(e) (op G.(e) (H.(i) G.(e)))); sauto.
eq_tac; sauto.
apply trans_equal with (op G.(e) (op G.(e) (H.(i) G.(e)))); sauto.
repeat rewrite  H.(assoc); sauto.
eq_tac; sauto.
apply trans_equal with G.(e); sauto.
apply trans_equal with (op G.(e) H.(e)); sauto.
eq_tac; sauto.
Qed.

(**************************************
   The proof works like this.
   If G = {e, g1, g2, g3, .., gn} and {e, h1, h2, h3, ..., hm}
   we construct the list mkGH
    {e, g1, g2, g3, ...., gn
     hi*e, hi * g1, hi * g2, ..., hi * gn   if hi does not appear before
     ....
     hk*e, hk * g1, hk * g2, ..., hk * gn   if hk does not appear before
     }
     that contains all the element of H.
   We show that this list does not contain double (ulist).
 **************************************)

Fixpoint mkList (base l: (list A)) { struct l}  : (list A) :=
  match l with
   nil => nil
 | cons a l1 => let r1 := mkList base l1 in
                         if (In_dec A_dec a r1) then r1 else
                          (map (op a) base) ++ r1
  end.

Definition mkGH := mkList G.(s) H.(s).

Theorem mkGH_length:  divide (length G.(s)) (length mkGH).
unfold mkGH; elim H.(s); simpl.
exists 0%nat; auto with arith.
intros a l1 (c, H1); case (In_dec A_dec a (mkList  G.(s) l1)); intros H2.
exists c; auto.
exists (1 + c)%nat; rewrite ListAux.length_app; rewrite ListAux.length_map; rewrite H1; ring.
Qed.

Theorem mkGH_incl: incl H.(s) mkGH.
assert (H1: forall l, incl l H.(s) -> incl l  (mkList G.(s) l)).
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1 H2.
case  (In_dec A_dec a (mkList (s G) l1)); auto with datatypes.
intros H3; assert (H4: incl l1 (mkList (s G) l1)).
apply H1; auto with datatypes.
intros b H4; apply H2; auto with datatypes.
intros b; simpl; intros [H5 | H5]; subst; auto.
intros _ b; simpl; intros [H3 | H3]; subst; auto.
apply in_or_app; left.
cut (In H.(e) G.(s)).
elim (s G); simpl; auto.
intros c l2 Hl2 [H3 | H3]; subst; sauto.
assert (In b H.(s)); sauto.
apply (H2 b); auto with datatypes.
rewrite same_e_for_H_and_G; sauto.
apply in_or_app; right.
apply H1; auto with datatypes.
apply incl_tran with (2:= H2); auto with datatypes.
unfold mkGH; apply H1; auto with datatypes.
Qed.

Theorem incl_mkGH: incl mkGH H.(s).
assert (H1: forall l, incl l H.(s) -> incl (mkList G.(s) l) H.(s)).
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1 H2.
case  (In_dec A_dec a (mkList (s G) l1)); intros H3; auto with datatypes.
apply H1; apply incl_tran with (2 := H2); auto with datatypes.
apply incl_app.
intros b H4.
case ListAux.in_map_inv with (1:= H4); auto.
intros c (Hc1, Hc2); subst; sauto.
apply internal; auto with datatypes.
apply H1; apply incl_tran with (2 := H2); auto with datatypes.
unfold mkGH; apply H1; auto with datatypes.
Qed.

Theorem ulist_mkGH: ulist mkGH.
assert (H1: forall l, incl l H.(s) -> ulist  (mkList G.(s) l)).
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1 H2.
case  (In_dec A_dec a (mkList (s G) l1)); intros H3; auto with datatypes.
apply H1; apply incl_tran with (2 := H2); auto with datatypes.
apply ulist_app; auto.
apply ulist_map; sauto.
intros x y H4 H5 H6; apply g_cancel_l with (g:= H) (a := a); sauto.
apply H2; auto with datatypes.
apply H1; apply incl_tran with (2 := H2); auto with datatypes.
intros b H4 H5.
case ListAux.in_map_inv with (1:= H4); auto.
intros c (Hc, Hc1); subst.
assert (H6: forall l a b,  In b G.(s) -> incl l H.(s) -> In a (mkList G.(s) l) -> In (op a b) (mkList G.(s) l)).
intros ll u v; elim ll; simpl; auto with datatypes.
intros w ll1 T0 T1 T2.
case  (In_dec A_dec w (mkList (s G) ll1)); intros T3 T4; auto with datatypes.
apply T0; auto; apply incl_tran with (2:= T2); auto with datatypes.
case in_app_or with (1 := T4); intros T5; auto with datatypes.
apply in_or_app; left.
case ListAux.in_map_inv with (1:= T5); auto.
intros z (Hz1, Hz2); subst.
replace (op (op w z) v) with (op w (op z v)); sauto.
apply in_map; sauto.
apply assoc with H; auto with datatypes.
apply in_or_app; right; auto with datatypes.
apply T0; try apply incl_tran with (2 := T2); auto with datatypes.
case H3; replace a with (op  (op a c) (G.(i) c)); auto with datatypes.
apply H6; sauto.
apply incl_tran with (2 := H2); auto with datatypes.
apply trans_equal with (op a (op c (G.(i) c))); sauto.
apply sym_equal; apply assoc with H; auto with datatypes.
replace (op c (G.(i) c)) with (G.(e)); sauto.
rewrite <- same_e_for_H_and_G.
assert (In a H.(s)); sauto; apply (H2 a); auto with datatypes.
unfold mkGH; apply H1; auto with datatypes.
Qed.

(**************************************
  Lagrange theorem
 **************************************)

Theorem lagrange: (g_order G | (g_order H)).
unfold g_order.
rewrite Permutation.permutation_length with  (l := H.(s)) (m:= mkGH).
case mkGH_length; intros x H1; exists (Z_of_nat x).
rewrite H1; rewrite Zmult_comm; apply inj_mult.
apply ulist_incl2_permutation; auto.
apply ulist_mkGH.
apply mkGH_incl.
apply incl_mkGH.
Qed.

End Lagrange.


Require Export LL.Misc.UtilsTactics.
Require Export LL.Misc.Database.

Require Export Coq.Classes.SetoidDec.

Require Export Coq.Classes.RelationClasses.
Require Export Coq.Relations.Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.DecidableClass.
Require Import Coq.Logic.FunctionalExtensionality.

(** ** Subexponential Signature

This class defines the set of indices that can be used in subexponentials.
For each of them, it is possible to define the axioms (D,T 4) that
it features and whether it is linear or unbounded

*)
Class SigSELL :=
  {
    subexp: Set;
    lt : relation subexp ; (* relation on subexp *)
    lt_pre : PreOrder lt ; (* "lt" is a preorder *)
    lt_dec : forall x y, {lt x  y} + {~ lt x  y}; (* "lt" is decidable *)
    I : list subexp;
    un : list subexp;
    (* unbounded labels *)
    u : subexp -> bool ;

    (* closure condition *)
    uClosure : forall x y,u x = true -> lt x y -> u y = true
   }.

#[global] Instance Lt_Reflexive `{SigSELL} : Reflexive lt.
Proof. apply @PreOrder_Reflexive;eauto. exact lt_pre. Qed.

#[global] Instance Lt_Transitive `{SigSELL} : Transitive lt.
Proof.  apply @PreOrder_Transitive;eauto. exact lt_pre. Qed.

(* All subexponentials are unbouded *)
Class USigSELL `{SigSELL}:=
  {
    allU: forall x, u x = true }.

Section SELLSignature.

  Context `{SI : SigSELL}.

  (** Decidibility on modalities *)
  Lemma subDec sub : forall x:subexp, {sub x = true} + {sub x = false}.
  Proof.
   intros;eauto using Sumbool.sumbool_of_bool.
  Qed.

  Lemma uDec : forall x, {u x = true} + {u x = false}.
  Proof.
  apply subDec.
  Qed.

  End SELLSignature.

  Global Hint Resolve lt_pre uClosure allU:core.