Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.
Open Scope type_scope.

Require Import ssreflect List Basic Equality.

Section QuantifyingStructure.
  (*************************)
  (* Quantifying Structure *)
  (*************************)

  Record QuantifyingStructures :=
    {
      Sorts : Type;
      QWorld: Type;
      Terms : QWorld -> Type;
      SoContexts: QWorld -> Type;
      SortingRel qLab : SoContexts qLab -> Terms qLab -> Sorts -> Prop
    }.

  (* We now assume we have a quantifying structure *)

  Variable QS: QuantifyingStructures.

  (**************************************)
  (* Useful definitions for types       *)
  (* (types are parameterised by terms) *)
  (**************************************)

  Inductive AList A : list QS.(Sorts) -> Type :=
  | TermNil   : AList A nil
  | TermCons s: A -> forall l, AList A l -> AList A (s::l).

  Definition TList (qLab:QS.(QWorld)) := AList (Terms qLab).

  Definition DPair A := {l: list QS.(Sorts) & A l}.

  Definition ex1 A (a:DPair A) :=
    match a with
      | existS l _ => l
    end.

  Definition ex2 A (a:DPair A): A (ex1 a) :=
    match a with
      | existS _ araw => araw
    end.

  Definition Inst A (qLab:QS.(QWorld)) := DPair (fun l => A l * TList qLab l).

  Definition getA     A qLab (a:Inst A qLab) := let (b,_) := ex2 a in b.
  Definition getTerms A qLab (a:Inst A qLab) := let (_,b) := ex2 a in b.

End QuantifyingStructure.

Notation "[ x , y ]" := (existS (fun l => _ l * TList _ l) _ (x,y)).

(*****************)
(* Decomposition *)
(*****************)

(* Dec Squeleton *)

Inductive DecStruct :=
| sleafP : DecStruct
| sleafN : DecStruct
| sdummy : DecStruct
| snode : DecStruct -> DecStruct -> DecStruct
| sqnode : DecStruct -> DecStruct.

(* Generic Decomposition type, with two kinds of leaves A and B *)

Inductive Dec {C A B: Type}: DecStruct -> Type  :=
| leafP : A -> Dec sleafP
| leafN : B -> Dec sleafN
| dummy : Dec sdummy
| node  : forall {s1 s2}, Dec s1 -> Dec s2 -> Dec (snode s1 s2)
| qnode : forall {s}, C -> Dec s -> Dec (sqnode s).

(* Lifting three relations RelQ, RelP and RelN, respectively between E
and F, between A and C and between B and D, into a relation between
Decs E A B and Decs F C D *)

Definition Declift (E F A B C D: Type)
           (RelQ: E -> F -> Prop)
           (RelP: A -> C -> Prop)
           (RelN: B -> D -> Prop)
           {st}
: @Dec E A B st -> @Dec F C D st -> Prop.
Proof.
  induction st; move => v Delta ; inversion v ; inversion Delta.
  exact (RelP X X0).
  exact (RelN X X0).
  exact True.
  exact ((IHst1 X X1)/\(IHst2 X0 X2)).
  exact ((RelQ X X1)/\(IHst X0 X2)).
Defined.

Global Arguments Declift {E F A B C D} RelQ RelP RelN [st] _ _.

Lemma Decstruct {C A B: Type} st:
  match st with
    | sleafP => forall (v:Dec (C := C) (A := A) (B := B) sleafP), exists a, v = leafP a
    | sleafN => forall (v:Dec (C := C) (A := A) (B := B) sleafN), exists a, v = leafN a
    | sdummy => forall (v:Dec (C := C) (A := A) (B := B) sdummy), v = dummy
    | snode s1 s2 => forall (v:Dec (C := C) (A := A) (B := B) (snode s1 s2)),
                    exists (v1:Dec s1)(v2:Dec s2), v = node v1 v2
    | sqnode s0 => forall (v:Dec (C := C) (A := A) (B := B) (sqnode s0)),
                    exists (v0:Dec s0) t, v = qnode t v0
  end.
Proof.
  assert
    (forall (v:Dec (C := C) (A := A) (B := B) st),
      match st with
        | sleafP => exists a, JMeq v (leafP (C := C) (A := A) (B := B) a)
        | sleafN => exists a, JMeq v (leafN (C := C) (A := A) (B := B) a)
        | sdummy => JMeq v (dummy (C := C) (A := A) (B := B) )
        | snode s1 s2 => exists (v1:Dec s1)(v2:Dec s2), JMeq v (node (C := C) (A := A) (B := B) v1 v2)
        | sqnode s0 => exists (v0:Dec s0) t, JMeq v (qnode (C := C) (A := A) (B := B) t v0)
      end
    ).
  move => v.
  by case v;
  [
    move => a; exists a
  | move => b; exists b
  |
  | move => s1 s2 v1 v2; exists v1; exists v2; apply JMeq_refl
  | move => s t v0; exists v0; exists t; apply JMeq_refl
  ].
  by move:H; case st
  =>  [ | | | s1 s2 | s ];
  move => H v; move:(H v); clear H;
         [ move => [a H]; exists a
         | move => [b H]; exists b
         | move => H
         | move => [v1 [v2 H]]; exists v1; exists v2
         | move => [v0 [t H]]; exists v0; exists t
         ]
  ;
  apply JMeq_eq.
Qed.

Section LAF.

  (*********)
  (* TYPES *)
  (*********)

  (* The language of types is given by
- Sorts:    sorts for terms
- Atom:     type of atoms
- Molecule: type of molecules *)

  Record QSTypes :=
    {
      QS :> QuantifyingStructures;
      Atom        : list QS.(Sorts) -> Type;
      Molecule    : list QS.(Sorts) -> Type;
      is_eq {qLab}: (Inst Atom qLab) -> (Inst Atom qLab) -> Prop
    }.

  Inductive TypingDec (QST: QSTypes): DecStruct -> list QST.(Sorts) -> Type  :=
  | TleafP : forall {l}, Atom l -> TypingDec sleafP l
  | TleafN : forall {l}, Molecule l -> TypingDec sleafN l
  | Tdummy : forall {l}, TypingDec sdummy l
  | Tnode  : forall {l s1 s2}, TypingDec s1 l -> TypingDec s2 l -> TypingDec (snode s1 s2) l
  | Tqnode : forall {l s} so, TypingDec s (so::l) -> TypingDec (sqnode s) l.

  (************)
  (* Contexts *)
  (************)

  (* Axiomatic specification for the implementation of contexts:

Contexts can be typing contexts (variables are mapped to "types"), or
substitutions (variables are mapped to "terms").

Contexts map quantifiable, positive and negative variables to elements
of C, A and B, respectively.
readq, readp and readn are for reading the values.
   *)

  Record World (QS:QuantifyingStructures) :=
    {
      PLab:Type;
      NLab:Type;
      QLab:QS.(QWorld)
    }.

  Record Contexts {QS:QuantifyingStructures}
         (wextends: DecStruct -> World QS -> World QS)
         (A B C:Type)(D:QS.(QWorld) -> Type) :=
    {
      Csupport w :> Type;
      readp w : Csupport w -> w.(PLab) -> A;
      readn w : Csupport w -> w.(NLab) -> B;
      readE w : Csupport w -> D w.(QLab);
      extends w st:
        forall v : @Dec C A B st, @Csupport w -> @Csupport (wextends st w)
    }.

  (* A typing context maps positive variables atoms and negative variables to molecules *)

  Record TypingContexts (QST:QSTypes)(wextends: DecStruct -> World QST -> World QST) :=
    {
      TCsupport w :> Type;
      Treadp w : TCsupport w -> w.(PLab) -> Inst Atom w.(QLab);
      Treadn w : TCsupport w -> w.(NLab) -> Inst Molecule w.(QLab);
      TreadE w : TCsupport w -> SoContexts w.(QLab);
      Textends w st:
        forall v : Inst (TypingDec st) w.(QLab), TCsupport w -> TCsupport (wextends st w)
    }.

  (* The language of proof-terms is parameterised by:
- Patterns: type of elements that can be thought as patterns
To each pattern p is associated a tree skeleton PatDec p
   *)

  Record LAFs :=
    {
      QST:> QSTypes;
      wextends : DecStruct -> World QST -> World QST;
      TContext : TypingContexts wextends;
      Patterns : Type;
      PatDec   : Patterns -> DecStruct;
      PatternsTyped (p:Patterns) l : @TypingDec QST (PatDec p) l -> Molecule l -> Prop
    }.

  Global Arguments TContext {_}.
  Global Arguments PatternsTyped {_} p {_} _ _.

  (* We assume we have an instance of LAF *)

  Variable LAF:LAFs.

  (***************)
  (* PROOF-TERMS *)
  (***************)

  (* The language of proof-terms has 5 syntactic categories:
- commands
(negative term+positive term)
- negative terms
(reification of a meta-level partial function from patterns to commands,
represented as a total function to option commands)
- positive terms
(pattern + prof-term tree)
- proof-term trees
("a way to fill the pattern's holes")
- option commands
(the result of a partial function to commands)
   *)

  Inductive Pos (w: World LAF):Type :=
  | pos: forall p: LAF.(Patterns), TermDec w (PatDec p) -> Pos w
  with TermDec (w: World LAF): DecStruct -> Type :=
       | tleafP: w.(PLab) -> TermDec w sleafP
       | tleafN: Neg w -> TermDec w sleafN
       | tdummy: TermDec w sdummy
       | tnode {s1 s2}: TermDec w s1 -> TermDec w s2 -> TermDec w (snode s1 s2)
       | tqnode {s}: Terms w.(QLab) -> TermDec w s -> TermDec w (sqnode s)
  with Neg (w: World LAF):Type :=
       | rei : (forall p:LAF.(Patterns), OptionCommand (wextends (PatDec p) w)) -> Neg w
  with OptionCommand (w: World LAF): Type :=
       | some: Command w -> OptionCommand w
       | none
  with Command (w: World LAF): Type :=
       | cut   : Neg w  -> Pos w -> Command w
       | select: w.(NLab) -> Pos w -> Command w.

  Global Arguments pos {w} p _.

  Scheme pos_ind :=
    Induction for Pos Sort Prop
    with termtree_ind :=
    Induction for TermDec Sort Prop
    with neg_ind :=
      Induction for Neg Sort Prop
      with ocommand_ind :=
        Induction for OptionCommand Sort Prop
        with command_ind :=
          Induction for Command Sort Prop.

  Combined Scheme term_ind from pos_ind, termtree_ind, neg_ind, ocommand_ind, command_ind.

  (*****************)
  (* Abbreviations *)
  (*****************)

  Definition Reifiable w := forall p:Patterns LAF, OptionCommand (wextends (PatDec p) w).

  (* Notation "x + y" := (sum x y). *)
  (* Definition NegVar w := @Neg w + w.(NLab). *)

  Inductive cexists_as {w} : OptionCommand w -> Command w -> Prop :=
    cnotnone: forall o, cexists_as (some o) o
  .

  Notation "x =cis= y" := (cexists_as x y) (at level 30, right associativity).

  Lemma somecis {w u} {c: Command w} : u =cis= c -> u = some c.
  Proof.
      by elim.
  Qed.

  (**********)
  (* TYPING *)
  (**********)

  (* This is the parameter that integrates the logical connectives.
It is a relation expressing:
"A formula can be decomposed into a TypingDec according to a pattern."
Example:
(A\/(B/\C)) can be decomposed into B,C according to the pattern inj2(_,_)
   *)

  (* Here is the typing system *)

  Inductive PosTyping {w} (Gamma: TContext w): Pos w -> Inst Molecule w.(QLab) -> Prop :=
  | typingpos: forall p l v Delta A (tl:TList w.(QLab) l),
                 PatternsTyped p Delta A
                 -> DecTyping Gamma v Delta tl
                 -> PosTyping Gamma (pos p v) [A,tl]

  with DecTyping {w} (Gamma: TContext w)
       : forall l {st}, TermDec w st -> TypingDec st l -> TList w.(QLab) l -> Prop :=
       | typingsub_leafl: forall l xp x (tl:TList w.(QLab) l),
                            is_eq (Treadp Gamma xp) [x,tl]
                            -> DecTyping Gamma (tleafP xp) (TleafP x) tl
       | typingsub_leafr: forall l nt A (tl:TList w.(QLab) l),
                            NegTyping Gamma nt [A,tl] ->
                            DecTyping Gamma (tleafN nt) (TleafN A) tl
       | typingsub_dummy: forall l (tl:TList w.(QLab) l),
                            DecTyping Gamma (tdummy w) Tdummy tl
       | typingsub_node: forall l s1 s2 (v1:TermDec w s1) (v2:TermDec w s2)
                           Delta1 Delta2 (tl:TList w.(QLab) l),
                           DecTyping Gamma v1 Delta1 tl
                           -> DecTyping Gamma v2 Delta2 tl
                           -> DecTyping Gamma (tnode v1 v2) (Tnode Delta1 Delta2) tl
       | typingsub_qnode: forall l s (v:TermDec w s) so Delta r (tl:TList w.(QLab) l),
                            SortingRel (TreadE Gamma) r so
                            -> DecTyping Gamma v Delta (TermCons so r tl)
                            -> DecTyping Gamma (tqnode r v) (Tqnode Delta) tl

  with NegTyping {w} (Gamma: TContext w) : Neg w -> Inst Molecule w.(QLab) -> Prop :=
       | typingneg: forall f l A tl,
                      (forall p c, f p =cis= c -> exists Delta, PatternsTyped p Delta A)
                      ->
                      (forall p (Delta:TypingDec _ l), (PatternsTyped p Delta A)
                                              -> OptionCommandTyping
                                                  (w := wextends (PatDec p) w)
                                                  (Textends [Delta,tl] Gamma)
                                                  (f p))
                      -> NegTyping Gamma (rei f) [A,tl]

  with OptionCommandTyping {w} (Gamma: TContext w): OptionCommand w -> Prop :=
       | typingoption: forall c,
                         CommandTyping Gamma c
                         -> OptionCommandTyping Gamma (some c)

  with CommandTyping {w} (Gamma: TContext w): Command w -> Prop :=
       | typingcut: forall nt pt A,
                      NegTyping Gamma nt A
                      -> PosTyping Gamma pt A
                      -> CommandTyping Gamma (cut nt pt)
       | typingselect: forall xn pt,
                         PosTyping Gamma pt (Treadn Gamma xn)
                         -> CommandTyping Gamma (select xn pt)
  .

  (* We create the induction principle on typing trees *)

  Scheme typingPos_ind :=
    Induction for PosTyping Sort Prop
    with typingSub_ind :=
    Induction for DecTyping Sort Prop
    with typingNeg_ind :=
      Induction for NegTyping Sort Prop
      with typingOptionCommand_ind :=
        Induction for OptionCommandTyping Sort Prop
        with typingCommand_ind := Induction for CommandTyping Sort Prop
  .

  Combined Scheme typing_ind from typingPos_ind, typingSub_ind, typingNeg_ind, typingOptionCommand_ind, typingCommand_ind.

End LAF.

Notation "x =cis= y" := (cexists_as x y) (at level 30, right associativity).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*********************************************************************)
(** * List permutations as a composition of adjacent transpositions  *)
(*********************************************************************)

(* Adapted in May 2006 by Jean-Marc Notin from initial contents by
   Laurent Théry (Huffmann contribution, October 2003) *)

(** TODO target in Type by Oliver Laurent 2018 *)

Require Import List Compare_dec CMorphisms FinFun.

Require Permutation.

Require Import List_Type.

Import ListNotations. (* For notations [] and [a;b;c] *)
Set Implicit Arguments.
(* Set Universe Polymorphism. *)

(**********************************************************************)
(** ** Predicate for List addition/removal (no need for decidability) in Type *)
(**********************************************************************)

Section Add_Type.

  Variable A : Type.

  (* [Add a l l'] means that [l'] is exactly [l], with [a] added
     once somewhere *)
  Inductive Add_Type (a:A) : list A -> list A -> Type :=
    | Add_Type_head l : Add_Type a l (a::l)
    | Add_Type_cons x l l' : Add_Type a l l' -> Add_Type a (x::l) (x::l').

  Lemma Add_Type_app a l1 l2 : Add_Type a (l1++l2) (l1++a::l2).
  Proof.
   induction l1; simpl; now constructor.
  Qed.

  Lemma Add_Type_split a l l' :
    Add_Type a l l' -> exists l1 l2, l = l1++l2 /\ l' = l1++a::l2.
  Proof.
   induction 1.
   - exists nil; exists l; split; trivial.
   - destruct IHX as (l1 & l2 & Hl & Hl').
     exists (x::l1); exists l2; split; simpl; f_equal; trivial.
  Qed.

  Lemma Add_Type_in a l l' : Add_Type a l l' ->
   forall x, In x l' <-> In x (a::l).
  Proof.
   induction 1; intros; simpl in *; rewrite ?IHX; tauto.
  Qed.

  Lemma Add_Type_in_Type a l l' : Add_Type a l l' ->
   forall x, In_Type x l' -> In_Type x (a::l).
  Proof.
   induction 1; intros; simpl in *; rewrite ?IHX; [ tauto | ].
   destruct X0 ; [ right ; left ; assumption | ].
   assert ((a = x0) + In_Type x0 l) ; try tauto.
   apply IHX ; assumption.
  Qed.

  Lemma Add_Type_length a l l' : Add_Type a l l' -> length l' = S (length l).
  Proof.
   induction 1; simpl; auto with arith.
  Qed.

  Lemma Add_Type_inv a l : In_Type a l -> { l' : _ &  Add_Type a l' l }.
  Proof.
   intro Ha. destruct (in_Type_split _ _ Ha) as ([l1 l2] & ->).
   exists (l1 ++ l2). apply Add_Type_app.
  Qed.

  Lemma incl_Add_Type_inv a l u v :
    (In_Type a l -> False) ->
    incl_Type (a::l) v -> Add_Type a u v -> incl_Type l u.
  Proof.
   intros Ha H AD y Hy.
   assert (Hy' : In_Type y (a::u)).
   { apply (Add_Type_in_Type AD). apply H; simpl; auto. }
   destruct Hy'; [ subst; now elim Ha | trivial ].
  Qed.

End Add_Type.

Section Permutation.

Variable A:Type.

Inductive Permutation_Type : list A -> list A -> Type :=
| Permutation_Type_nil_nil : Permutation_Type [] []
| Permutation_Type_skip x l l' : Permutation_Type l l' -> Permutation_Type (x::l) (x::l')
| Permutation_Type_swap x y l : Permutation_Type (y::x::l) (x::y::l)
| Permutation_Type_trans l l' l'' :
    Permutation_Type l l' -> Permutation_Type l' l'' -> Permutation_Type l l''.

Local Hint Constructors Permutation_Type.

(** Some facts about [Permutation] *)

Theorem Permutation_Type_nil : forall (l : list A), Permutation_Type [] l -> l = [].
Proof.
  intros l HF.
  remember (@nil A) as m in HF.
  induction HF; discriminate || auto.
Qed.

Theorem Permutation_Type_nil_cons : forall (l : list A) (x : A),
 Permutation_Type nil (x::l) -> False.
Proof.
  intros l x HF.
  apply Permutation_Type_nil in HF; discriminate.
Qed.

(** Permutation over lists is a equivalence relation *)

Theorem Permutation_Type_refl : forall l : list A, Permutation_Type l l.
Proof.
  induction l; constructor. exact IHl.
Qed.

Theorem Permutation_Type_sym : forall l l' : list A,
 Permutation_Type l l' -> Permutation_Type l' l.
Proof.
  intros l l' Hperm; induction Hperm; auto.
  apply Permutation_Type_trans with (l':=l'); assumption.
Qed.

(*
Theorem Permutation_Type_trans : forall l l' l'' : list A,
 Permutation l l' -> Permutation l' l'' -> Permutation l l''.
Proof.
  exact perm_trans.
Qed.
*)

End Permutation.

Hint Resolve Permutation_Type_refl Permutation_Type_nil_nil Permutation_Type_skip.

(* These hints do not reduce the size of the problem to solve and they
   must be used with care to avoid combinatoric explosions *)

Local Hint Resolve Permutation_Type_swap Permutation_Type_trans.
Local Hint Resolve Permutation_Type_sym.

(* This provides reflexivity, symmetry and transitivity and rewriting
   on morphims to come *)

Instance Permutation_Type_Equivalence A : Equivalence (@Permutation_Type A) | 10 := {
  Equivalence_Reflexive := @Permutation_Type_refl A ;
  Equivalence_Symmetric := @Permutation_Type_sym A ;
  Equivalence_Transitive := @Permutation_Type_trans A }.

Instance Permutation_Type_cons A :
 Proper (Logic.eq ==> @Permutation_Type A ==> @Permutation_Type A) (@cons A) | 10.
Proof.
  repeat intro; subst; auto using Permutation_Type_skip.
Qed.

Section Permutation_properties.

Variable A:Type.

Implicit Types a b : A.
Implicit Types l m : list A.

(** Compatibility with others operations on lists *)

Theorem Permutation_Type_in : forall (l l' : list A) (x : A),
 Permutation_Type l l' -> In x l -> In x l'.
Proof.
  intros l l' x Hperm; induction Hperm; simpl; tauto.
Qed.

Global Instance Permutation_Type_in' :
 Proper (Logic.eq ==> @Permutation_Type A ==> iff) (@In A) | 10.
Proof.
  repeat red; intros; subst; eauto using Permutation_Type_in.
Qed.

Theorem Permutation_Type_in_Type : forall (l l' : list A) (x : A),
 Permutation_Type l l' -> In_Type x l -> In_Type x l'.
Proof.
  intros l l' x Hperm; induction Hperm; simpl; tauto.
Qed.

Global Instance Permutation_Type_in_Type' :
 Proper (Logic.eq ==> @Permutation_Type A ==> Basics.arrow) (@In_Type A) | 10.
Proof.
  intros l1 l2 Heq l1' l2' HP Hi ; subst.
  eauto using Permutation_Type_in_Type.
Qed.

Lemma Permutation_Type_app_tail : forall (l l' tl : list A),
 Permutation_Type l l' -> Permutation_Type (l++tl) (l'++tl).
Proof.
  intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
  eapply Permutation_Type_trans with (l':=l'++tl); trivial.
Qed.

Lemma Permutation_Type_app_head : forall (l tl tl' : list A),
 Permutation_Type tl tl' -> Permutation_Type (l++tl) (l++tl').
Proof.
  intros l tl tl' Hperm; induction l;
   [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
Qed.

Theorem Permutation_Type_app : forall (l m l' m' : list A),
 Permutation_Type l l' -> Permutation_Type m m' -> Permutation_Type (l++m) (l'++m').
Proof.
  intros l m l' m' Hpermll' Hpermmm';
   induction Hpermll' as [|x l l'|x y l|l l' l''];
    repeat rewrite <- app_comm_cons; auto.
  apply Permutation_Type_trans with (l' := (x :: y :: l ++ m));
   [idtac | repeat rewrite app_comm_cons; apply Permutation_Type_app_head]; trivial.
  apply Permutation_Type_trans with (l' := (l' ++ m')); try assumption.
  apply Permutation_Type_app_tail; assumption.
Qed.

Global Instance Permutation_Type_app' :
 Proper (@Permutation_Type A ==> @Permutation_Type A ==> @Permutation_Type A) (@app A) | 10.
Proof.
  repeat intro; now apply Permutation_Type_app.
Qed.

Lemma Permutation_Type_add_inside : forall a (l l' tl tl' : list A),
  Permutation_Type l l' -> Permutation_Type tl tl' ->
  Permutation_Type (l ++ a :: tl) (l' ++ a :: tl').
Proof.
  intros; apply Permutation_Type_app; auto.
Qed.

Lemma Permutation_Type_cons_append : forall (l : list A) x,
  Permutation_Type (x :: l) (l ++ x :: nil).
Proof. induction l; intros; auto. simpl.
eapply Permutation_Type_trans ; [ apply Permutation_Type_swap | apply Permutation_Type_skip ].
apply IHl. Qed.
Local Hint Resolve Permutation_Type_cons_append.

Theorem Permutation_Type_app_comm : forall (l l' : list A),
  Permutation_Type (l ++ l') (l' ++ l).
Proof.
  induction l as [|x l]; simpl; intro l'.
  rewrite app_nil_r; trivial.
  eapply Permutation_Type_trans ; [ apply Permutation_Type_skip ; apply IHl | ].
  rewrite app_comm_cons.
  replace (l' ++ x :: l) with ((l' ++ x :: nil) ++ l)
    by (rewrite <- app_assoc ; reflexivity).
  apply Permutation_Type_app_tail. apply Permutation_Type_cons_append.
Qed.
Local Hint Resolve Permutation_Type_app_comm.

Theorem Permutation_Type_cons_app : forall (l l1 l2:list A) a,
  Permutation_Type l (l1 ++ l2) -> Permutation_Type (a :: l) (l1 ++ a :: l2).
Proof.
  intros l l1 l2 a H.
  eapply Permutation_Type_trans ; [ apply Permutation_Type_skip ; apply H | ].
  rewrite app_comm_cons.
  replace (l1 ++ a :: l2) with ((l1 ++ a :: nil) ++ l2)
    by (rewrite <- app_assoc ; reflexivity).
  apply Permutation_Type_app_tail. apply Permutation_Type_cons_append.
Qed.
Local Hint Resolve Permutation_Type_cons_app.

Lemma Permutation_Type_Add_Type a l l' : Add_Type a l l' -> Permutation_Type (a::l) l'.
Proof.
 induction 1; simpl; trivial.
 eapply Permutation_Type_trans ; [ apply Permutation_Type_swap | ].
 now apply Permutation_Type_skip.
Qed.

Theorem Permutation_Type_middle : forall (l1 l2:list A) a,
  Permutation_Type (a :: l1 ++ l2) (l1 ++ a :: l2).
Proof.
  auto.
Qed.
Local Hint Resolve Permutation_Type_middle.

Theorem Permutation_Type_rev : forall (l : list A), Permutation_Type l (rev l).
Proof.
  induction l as [| x l]; simpl; trivial.
  eapply Permutation_Type_trans ; [ apply Permutation_Type_cons_append | ].
  apply Permutation_Type_app_tail. assumption.
Qed.

Global Instance Permutation_Type_rev' :
 Proper (@Permutation_Type A ==> @Permutation_Type A) (@rev A) | 10.
Proof.
  intros l1 l2 HP.
  eapply Permutation_Type_trans ; [ | eapply Permutation_Type_trans ].
  - apply Permutation_Type_sym.
    apply Permutation_Type_rev.
  - eassumption.
  - apply Permutation_Type_rev.
Qed.

Theorem Permutation_Type_length : forall (l l' : list A),
 Permutation_Type l l' -> length l = length l'.
Proof.
  intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l').
Qed.

Global Instance Permutation_Type_length' :
 Proper (@Permutation_Type A ==> Logic.eq) (@length A) | 10.
Proof.
  exact Permutation_Type_length.
Qed.

Theorem Permutation_Type_ind_bis :
 forall P : list A -> list A -> Prop,
   P [] [] ->
   (forall x l l', Permutation_Type l l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l l', Permutation_Type l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
   (forall l l' l'', Permutation_Type l l' -> P l l' -> Permutation_Type l' l'' -> P l' l'' -> P l l'') ->
   forall l l', Permutation_Type l l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans.
  induction 1; auto.
  apply Htrans with (x::y::l); auto.
  apply Hswap; auto.
  induction l; auto.
  apply Hskip; auto.
  apply Hskip; auto.
  induction l; auto.
  eauto.
Qed.

Theorem Permutation_Type_rect_bis :
 forall P : list A -> list A -> Type,
   P [] [] ->
   (forall x l l', Permutation_Type l l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l l', Permutation_Type l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
   (forall l l' l'', Permutation_Type l l' -> P l l' -> Permutation_Type l' l'' -> P l' l'' -> P l l'') ->
   forall l l', Permutation_Type l l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans.
  induction 1; auto.
  apply Htrans with (x::y::l); auto.
  apply Hswap; auto.
  induction l; auto.
  apply Hskip; auto.
  apply Hskip; auto.
  induction l; auto.
  eauto.
Qed.

Theorem Permutation_Type_nil_app_cons : forall (l l' : list A) (x : A),
 Permutation_Type nil (l++x::l') -> False.
Proof.
  intros l l' x HF.
  apply Permutation_Type_nil in HF. destruct l; discriminate.
Qed.

Ltac InvAdd_Type := repeat (match goal with
 | H: Add_Type ?x _ (_ :: _) |- _ => inversion H; clear H; subst
 end).

Ltac finish_basic_perms_Type H :=
  try constructor; try rewrite Permutation_Type_swap; try constructor; trivial;
  (rewrite <- H; now apply Permutation_Type_Add_Type) ||
  (rewrite H; symmetry; now apply Permutation_Type_Add_Type).

Theorem Permutation_Type_Add_Type_inv a l1 l2 :
  Permutation_Type l1 l2 -> forall l1' l2', Add_Type a l1' l1 -> Add_Type a l2' l2 ->
   Permutation_Type l1' l2'.
Proof.
 revert l1 l2. refine (Permutation_Type_rect_bis _ _ _ _ _).
 - (* nil *)
   inversion_clear 1.
 - (* skip *)
   intros x l1 l2 PE IH. intros. InvAdd_Type; try finish_basic_perms_Type PE.
   + eapply Permutation_Type_trans ; [ | apply PE ].
     apply Permutation_Type_Add_Type.
     assumption.
   + eapply Permutation_Type_trans ; [ apply PE | ].
     apply Permutation_Type_sym.
     apply Permutation_Type_Add_Type.
     assumption.
   + constructor. now apply IH.
 - (* swap *)
   intros x y l1 l2 PE IH. intros. InvAdd_Type; try finish_basic_perms_Type PE.
   + apply Permutation_Type_skip.
     eapply Permutation_Type_trans ; [ | apply PE ].
     apply Permutation_Type_Add_Type.
     assumption.
   + apply Permutation_Type_sym.
     change (y :: x :: l0) with ((y :: nil) ++ x :: l0).
     apply Permutation_Type_cons_app.
     apply Permutation_Type_sym.
     eapply Permutation_Type_trans ; [ | apply PE ].
     apply Permutation_Type_Add_Type.
     assumption.
   + apply Permutation_Type_skip.
     eapply Permutation_Type_trans ; [ apply PE | ].
     apply Permutation_Type_sym.
     apply Permutation_Type_Add_Type.
     assumption.
   + change (x :: y :: l0) with ((x :: nil) ++ y :: l0).
     apply Permutation_Type_cons_app.
     eapply Permutation_Type_trans ; [ apply PE | ].
     apply Permutation_Type_sym.
     apply Permutation_Type_Add_Type.
     assumption.
   + eapply Permutation_Type_trans ; [ apply Permutation_Type_swap | ].
     do 2 constructor. now apply IH.
 - (* trans *)
   intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2.
   assert {l' : list A & Add_Type a l' l } as [l' AD].
   { clear IH PE' IH' AD2 l2 l2'. revert l1' AD1. induction PE ; intros.
     - inversion AD1.
     - inversion AD1 ; subst.
       + apply (existT _ l'). constructor.
       + apply IHPE in X.
         destruct X as [l'0 X].
         apply (existT _ (x :: l'0)).
         constructor. assumption.
     - inversion AD1 ; subst.
       + apply (existT _ (x :: l)). do 2 constructor.
       + inversion X ; subst.
         * apply (existT _ (y :: l)). do 2 constructor.
         * apply (existT _ (x :: y :: l1)). do 2 constructor. assumption.
     - apply IHPE1 in AD1.
       destruct AD1 as [l'0 AD1]. apply IHPE2 in AD1. assumption. }
   eapply Permutation_Type_trans.
   + apply IH.
     * apply AD1.
     * apply AD.
   + now apply IH'.
Qed.

Theorem Permutation_Type_app_inv (l1 l2 l3 l4:list A) a :
  Permutation_Type (l1++a::l2) (l3++a::l4) -> Permutation_Type (l1++l2) (l3 ++ l4).
Proof.
 intros. eapply Permutation_Type_Add_Type_inv; eauto using Add_Type_app.
Qed.

Theorem Permutation_Type_cons_inv l l' a :
 Permutation_Type (a::l) (a::l') -> Permutation_Type l l'.
Proof.
  intro. eapply Permutation_Type_Add_Type_inv; eauto using Add_Type_head.
Qed.

Theorem Permutation_Type_cons_app_inv l l1 l2 a :
 Permutation_Type (a :: l) (l1 ++ a :: l2) -> Permutation_Type l (l1 ++ l2).
Proof.
  intro. eapply Permutation_Type_Add_Type_inv; eauto using Add_Type_head, Add_Type_app.
Qed.

Theorem Permutation_Type_app_inv_l : forall l l1 l2,
 Permutation_Type (l ++ l1) (l ++ l2) -> Permutation_Type l1 l2.
Proof.
  induction l; simpl; auto.
  intros.
  apply IHl.
  apply Permutation_Type_cons_inv with a; auto.
Qed.

Theorem Permutation_Type_app_inv_r l l1 l2 :
 Permutation_Type (l1 ++ l) (l2 ++ l) -> Permutation_Type l1 l2.
Proof.
 intros HP.
 eapply Permutation_Type_trans in HP ; [ | apply Permutation_Type_app_comm ].
 eapply Permutation_Type_app_inv_l.
 eapply Permutation_Type_trans ; [ apply HP | ].
 apply Permutation_Type_app_comm.
Qed.

Lemma Permutation_Type_length_1_inv: forall a l, Permutation_Type [a] l -> l = [a].
Proof.
  intros a l H; remember [a] as m in H.
  induction H; try (injection Heqm as -> ->);
    discriminate || auto.
  apply Permutation_Type_nil in H as ->; trivial.
Qed.

Lemma Permutation_Type_length_1: forall a b, Permutation_Type [a] [b] -> a = b.
Proof.
  intros a b H.
  apply Permutation_Type_length_1_inv in H; injection H as ->; trivial.
Qed.

Lemma Permutation_Type_length_2_inv :
  forall a1 a2 l, Permutation_Type [a1;a2] l -> { l = [a1;a2] } + { l = [a2;a1] }.
Proof.
  intros a1 a2 l H; remember [a1;a2] as m in H.
  revert a1 a2 Heqm.
  induction H; intros; try (injection Heqm as ? ?; subst);
    discriminate || (try tauto).
  apply Permutation_Type_length_1_inv in H as ->; left; auto.
  apply IHPermutation_Type1 in Heqm as [H1|H1]; apply IHPermutation_Type2 in H1 as [];
    auto.
Qed.

Lemma Permutation_Type_length_2 :
  forall a1 a2 b1 b2, Permutation_Type [a1;a2] [b1;b2] ->
    { a1 = b1 /\ a2 = b2 } + { a1 = b2 /\ a2 = b1 }.
Proof.
  intros a1 b1 a2 b2 H.
  apply Permutation_Type_length_2_inv in H as [H|H]; injection H as -> ->; auto.
Qed.

(* TODO
Lemma NoDup_Permutation l l' : NoDup l -> NoDup l' ->
  (forall x:A, In x l <-> In x l') -> Permutation l l'.
Proof.
 intros N. revert l'. induction N as [|a l Hal Hl IH].
 - destruct l'; simpl; auto.
   intros Hl' H. exfalso. rewrite (H a); auto.
 - intros l' Hl' H.
   assert (Ha : In a l') by (apply H; simpl; auto).
   destruct (Add_inv _ _ Ha) as (l'' & AD).
   rewrite <- (Permutation_Add AD).
   apply perm_skip.
   apply IH; clear IH.
   * now apply (NoDup_Add AD).
   * split.
     + apply incl_Add_inv with a l'; trivial. intro. apply H.
     + intro Hx.
       assert (Hx' : In x (a::l)).
       { apply H. rewrite (Add_in AD). now right. }
       destruct Hx'; simpl; trivial. subst.
       rewrite (NoDup_Add AD) in Hl'. tauto.
Qed.

Lemma NoDup_Permutation_bis l l' : NoDup l -> NoDup l' ->
  length l' <= length l -> incl l l' -> Permutation l l'.
Proof.
 intros. apply NoDup_Permutation; auto.
 split; auto. apply NoDup_length_incl; trivial.
Qed.

Lemma Permutation_NoDup l l' : Permutation l l' -> NoDup l -> NoDup l'.
Proof.
 induction 1; auto.
 * inversion_clear 1; constructor; eauto using Permutation_in.
 * inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *.
   constructor. simpl; intuition. constructor; intuition.
Qed.

Global Instance Permutation_NoDup' :
 Proper (@Permutation A ==> iff) (@NoDup A) | 10.
Proof.
  repeat red; eauto using Permutation_NoDup.
Qed.
*)

End Permutation_properties.

Section Permutation_map.

Variable A B : Type.
Variable f : A -> B.

Lemma Permutation_Type_map l l' :
  Permutation_Type l l' -> Permutation_Type (map f l) (map f l').
Proof.
 induction 1; simpl; eauto.
Qed.

Global Instance Permutation_Type_map' :
  Proper (@Permutation_Type A ==> @Permutation_Type B) (map f) | 10.
Proof.
  exact Permutation_Type_map.
Qed.

End Permutation_map.

(*
Lemma nat_bijection_Permutation n f :
 bFun n f ->
 Injective f ->
 let l := seq 0 n in Permutation (map f l) l.
Proof.
 intros Hf BD.
 apply NoDup_Permutation_bis; auto using Injective_map_NoDup, seq_NoDup.
 * now rewrite map_length.
 * intros x. rewrite in_map_iff. intros (y & <- & Hy').
   rewrite in_seq in *. simpl in *.
   destruct Hy' as (_,Hy'). auto with arith.
Qed.
*)

(* TODO
Section Permutation_alt.
Variable A:Type.
Implicit Type a : A.
Implicit Type l : list A.

(** Alternative characterization of permutation
    via [nth_error] and [nth] *)

Let adapt f n :=
 let m := f (S n) in if le_lt_dec m (f 0) then m else pred m.

Let adapt_injective f : Injective f -> Injective (adapt f).
Proof.
 unfold adapt. intros Hf x y EQ.
 destruct le_lt_dec as [LE|LT]; destruct le_lt_dec as [LE'|LT'].
 - now apply eq_add_S, Hf.
 - apply Lt.le_lt_or_eq in LE.
   destruct LE as [LT|EQ']; [|now apply Hf in EQ'].
   unfold lt in LT. rewrite EQ in LT.
   rewrite <- (Lt.S_pred _ _ LT') in LT.
   elim (Lt.lt_not_le _ _ LT' LT).
 - apply Lt.le_lt_or_eq in LE'.
   destruct LE' as [LT'|EQ']; [|now apply Hf in EQ'].
   unfold lt in LT'. rewrite <- EQ in LT'.
   rewrite <- (Lt.S_pred _ _ LT) in LT'.
   elim (Lt.lt_not_le _ _ LT LT').
 - apply eq_add_S, Hf.
   now rewrite (Lt.S_pred _ _ LT), (Lt.S_pred _ _ LT'), EQ.
Qed.

Let adapt_ok a l1 l2 f : Injective f -> length l1 = f 0 ->
 forall n, nth_error (l1++a::l2) (f (S n)) = nth_error (l1++l2) (adapt f n).
Proof.
 unfold adapt. intros Hf E n.
 destruct le_lt_dec as [LE|LT].
 - apply Lt.le_lt_or_eq in LE.
   destruct LE as [LT|EQ]; [|now apply Hf in EQ].
   rewrite <- E in LT.
   rewrite 2 nth_error_app1; auto.
 - rewrite (Lt.S_pred _ _ LT) at 1.
   rewrite <- E, (Lt.S_pred _ _ LT) in LT.
   rewrite 2 nth_error_app2; auto with arith.
   rewrite <- Minus.minus_Sn_m; auto with arith.
Qed.

Lemma Permutation_nth_error l l' :
 Permutation l l' <->
  (length l = length l' /\
   exists f:nat->nat,
    Injective f /\ forall n, nth_error l' n = nth_error l (f n)).
Proof.
 split.
 { intros P.
   split; [now apply Permutation_length|].
   induction P.
   - exists (fun n => n).
     split; try red; auto.
   - destruct IHP as (f & Hf & Hf').
     exists (fun n => match n with O => O | S n => S (f n) end).
     split; try red.
     * intros [|y] [|z]; simpl; now auto.
     * intros [|n]; simpl; auto.
   - exists (fun n => match n with 0 => 1 | 1 => 0 | n => n end).
     split; try red.
     * intros [|[|z]] [|[|t]]; simpl; now auto.
     * intros [|[|n]]; simpl; auto.
   - destruct IHP1 as (f & Hf & Hf').
     destruct IHP2 as (g & Hg & Hg').
     exists (fun n => f (g n)).
     split; try red.
     * auto.
     * intros n. rewrite <- Hf'; auto. }
 { revert l. induction l'.
   - intros [|l] (E & _); now auto.
   - intros l (E & f & Hf & Hf').
     simpl in E.
     assert (Ha : nth_error l (f 0) = Some a)
      by (symmetry; apply (Hf' 0)).
     destruct (nth_error_split l (f 0) Ha) as (l1 & l2 & L12 & L1).
     rewrite L12. rewrite <- Permutation_middle. constructor.
     apply IHl'; split; [|exists (adapt f); split].
     * revert E. rewrite L12, !app_length. simpl.
       rewrite <- plus_n_Sm. now injection 1.
     * now apply adapt_injective.
     * intro n. rewrite <- (adapt_ok a), <- L12; auto.
       apply (Hf' (S n)). }
Qed.

Lemma Permutation_nth_error_bis l l' :
 Permutation l l' <->
  exists f:nat->nat,
    Injective f /\
    bFun (length l) f /\
    (forall n, nth_error l' n = nth_error l (f n)).
Proof.
 rewrite Permutation_nth_error; split.
 - intros (E & f & Hf & Hf').
   exists f. do 2 (split; trivial).
   intros n Hn.
   destruct (Lt.le_or_lt (length l) (f n)) as [LE|LT]; trivial.
   rewrite <- nth_error_None, <- Hf', nth_error_None, <- E in LE.
   elim (Lt.lt_not_le _ _ Hn LE).
 - intros (f & Hf & Hf2 & Hf3); split; [|exists f; auto].
   assert (H : length l' <= length l') by auto with arith.
   rewrite <- nth_error_None, Hf3, nth_error_None in H.
   destruct (Lt.le_or_lt (length l) (length l')) as [LE|LT];
    [|apply Hf2 in LT; elim (Lt.lt_not_le _ _ LT H)].
   apply Lt.le_lt_or_eq in LE. destruct LE as [LT|EQ]; trivial.
   rewrite <- nth_error_Some, Hf3, nth_error_Some in LT.
   assert (Hf' : bInjective (length l) f).
   { intros x y _ _ E. now apply Hf. }
   rewrite (bInjective_bSurjective Hf2) in Hf'.
   destruct (Hf' _ LT) as (y & Hy & Hy').
   apply Hf in Hy'. subst y. elim (Lt.lt_irrefl _ Hy).
Qed.

Lemma Permutation_nth l l' d :
 Permutation l l' <->
  (let n := length l in
   length l' = n /\
   exists f:nat->nat,
    bFun n f /\
    bInjective n f /\
    (forall x, x < n -> nth x l' d = nth (f x) l d)).
Proof.
 split.
 - intros H.
   assert (E := Permutation_length H).
   split; auto.
   apply Permutation_nth_error_bis in H.
   destruct H as (f & Hf & Hf2 & Hf3).
   exists f. split; [|split]; auto.
   intros x y _ _ Hxy. now apply Hf.
   intros n Hn. rewrite <- 2 nth_default_eq. unfold nth_default.
    now rewrite Hf3.
 - intros (E & f & Hf1 & Hf2 & Hf3).
   rewrite Permutation_nth_error.
   split; auto.
   exists (fun n => if le_lt_dec (length l) n then n else f n).
   split.
   * intros x y.
     destruct le_lt_dec as [LE|LT];
      destruct le_lt_dec as [LE'|LT']; auto.
     + apply Hf1 in LT'. intros ->.
       elim (Lt.lt_irrefl (f y)). eapply Lt.lt_le_trans; eauto.
     + apply Hf1 in LT. intros <-.
       elim (Lt.lt_irrefl (f x)). eapply Lt.lt_le_trans; eauto.
   * intros n.
     destruct le_lt_dec as [LE|LT].
     + assert (LE' : length l' <= n) by (now rewrite E).
       rewrite <- nth_error_None in LE, LE'. congruence.
     + assert (LT' : n < length l') by (now rewrite E).
       specialize (Hf3 n LT). rewrite <- 2 nth_default_eq in Hf3.
       unfold nth_default in Hf3.
       apply Hf1 in LT.
       rewrite <- nth_error_Some in LT, LT'.
       do 2 destruct nth_error; congruence.
Qed.

End Permutation_alt.
*)

(* begin hide *)
Notation Permutation_Type_app_swap := Permutation_Type_app_comm (only parsing).
(* end hide *)

Lemma Permutation_Type_Permutation {A} : forall l1 l2 : list A,
  Permutation_Type l1 l2 -> Permutation.Permutation l1 l2.
Proof.
intros l1 l2 HP.
induction HP ; try constructor ; try assumption.
etransitivity ; eassumption.
Qed.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require mathcomp.ssreflect.ssreflect.
From mathcomp
Require ssrbool ssrfun eqtype ssrnat fintype finset fingroup.
From mathcomp
Require morphism quotient action gfunctor gproduct commutator gseries nilpotent.
From odd_order
Require PFsection14.

(******************************************************************************)
(* This file contains a minimal, self-contained reformulation of the Odd      *)
(* Order theorem, using only the bare Coq logic, and avoiding any use of      *)
(* extra-logical features such as notation, coercion or implicit arguments.   *)
(* This stripped theorem would hardly be usable, however; it just provides    *)
(* evidence for the sceptics.                                                 *)
(******************************************************************************)

(* Equivalence and equality *)

Inductive equivalent P Q := Equivalent (P_to_Q : P -> Q) (Q_to_P : Q -> P).

Inductive equal T (x : T) : T -> Type := Equal : equal T x x.

(* Arithmetic *)

Inductive natural := Zero | Add_1_to (n : natural).

Fixpoint add (m n : natural) : natural :=
  match m with Zero => n | Add_1_to m_minus_1 => add m_minus_1 (Add_1_to n) end.

Definition double (n : natural) : natural := add n n.

Inductive odd (n : natural) :=
  Odd (half : natural)
    (n_odd : equal natural n (Add_1_to (double half))).

Inductive less_than (m n : natural) :=
  LessThan (diff : natural)
    (m_lt_n : equal natural n (Add_1_to (add m diff))).

(* Finite subsets *)

Definition injective_in T R (D : T -> Type) (f : T -> R) :=
  forall x y, D x -> D y -> equal R (f x) (f y) -> equal T x y.

Inductive in_image T R (D : T -> Type) (f : T -> R) (a : R) :=
  InImage (x : T) (x_in_D : D x) (a_is_fx : equal R a (f x)).

Inductive finite_of_order T (D : T -> Type) (n : natural) :=
  FiniteOfOrder (rank : T -> natural)
    (rank_injective : injective_in T natural D rank)
    (rank_onto :
       forall i, equivalent (less_than i n) (in_image T natural D rank i)).

(* Elementary group theory *)

Inductive group_axioms T (mul : T -> T -> T) (one : T) (inv : T -> T) :=
  GroupAxioms
    (associativity : forall x y z, equal T (mul x (mul y z)) (mul (mul x y) z))
    (left_identity : forall x,     equal T (mul one x) x)
    (left_inverse  : forall x,     equal T (mul (inv x) x) one).

Inductive group T mul one inv (G : T -> Type) :=
  Group
    (G_closed_under_mul : forall x y, G x -> G y -> G (mul x y))
    (one_in_G           : G one)
    (G_closed_under_inv : forall x, G x -> G (inv x)).

Inductive subgroup T mul one inv (H G : T -> Type) :=
  Subgroup
    (H_group    : group T mul one inv H)
    (H_subset_G : forall x, H x -> G x).

Inductive normal_subgroup T mul one inv (H G : T -> Type) :=
  NormalSubgroup
    (H_subgroup_G     : subgroup T mul one inv H G)
    (H_is_G_invariant : forall x y, H x -> G y -> H (mul (inv y) (mul x y))).

Inductive commute_mod T mul (x y : T) (H : T -> Type) :=
  CommuteMod (z : T)
    (z_in_H    : H z)
    (xy_eq_zyx : equal T (mul x y) (mul z (mul y x))).

Inductive abelian_factor T mul one inv (G H : T -> Type) :=
  AbelianFactor
    (G_group        : group T mul one inv G)
    (H_normal_in_G  : normal_subgroup T mul one inv H G)
    (G_on_H_abelian : forall x y, G x -> G y -> commute_mod T mul x y H).

Inductive solvable_group T mul one inv (G : T -> Type) :=
| TrivialGroupSolvable
   (G_trivial : forall x, equivalent (G x) (equal T x one))
| AbelianExtensionSolvable (H : T -> Type)
   (H_solvable     : solvable_group T mul one inv H)
   (G_on_H_abelian : abelian_factor T mul one inv G H).

(* begin hide *)
Module InternalSkepticOddOrderProof.

Local Notation Aeq := (equal _).
Local Notation Aadd := add.
Local Notation Adouble := double.
Local Notation Aodd := odd.
Local Notation Alt := less_than.
Local Notation Agroup := group.
Local Notation Asubgroup := subgroup.
Local Notation Anormal := normal_subgroup.
Local Notation Aabel_quo := abelian_factor.
Local Notation Asol := solvable_group.

Import Prelude ssreflect ssrbool ssrfun eqtype ssrnat fintype finset fingroup.
Import morphism quotient action gfunctor gproduct commutator gseries nilpotent.
Import GroupScope.

Lemma main T mul one inv G nn :
    group_axioms T mul one inv -> Agroup T mul one inv G ->
    finite_of_order T G nn -> Aodd nn ->
  Asol T mul one inv G.
Proof.
pose fix natN n := if n is n1.+1 then Add_1_to (natN n1) else Zero.
pose fix Nnat mm := if mm is Add_1_to mm1 then (Nnat mm1).+1 else 0.
have natN_K: cancel natN Nnat by elim=> //= n ->.
have NnatK: cancel Nnat natN by elim=> //= mm ->.
have AaddE nn1 nn2: Nnat (Aadd nn1 nn2) = Nnat nn1 + Nnat nn2.
  by elim: nn1 nn2 => //= nn1 IHnn nn2; rewrite IHnn addnS.
have AltE m n: Alt (natN m) (natN n) -> m < n.
  by rewrite -{2}[n]natN_K => [[dd ->]]; rewrite /= ltnS AaddE natN_K leq_addr.
have AltI m n: m < n -> Alt (natN m) (natN n).
  move/subnKC <-; exists (natN (n - m.+1)).
  by rewrite -[Add_1_to _]NnatK /= AaddE !natN_K.
have AoddE n: Aodd (natN n) -> odd n.
  by rewrite -{2}[n]natN_K => [[hh ->]]; rewrite /= AaddE addnn odd_double.
case=> mulA mul1T mulVT [mulG oneG invG] [rG inj_rG im_rG] odd_nn.
pose n := Nnat nn; have{odd_nn} odd_n: odd n by rewrite AoddE ?NnatK.
have{rG inj_rG im_rG} [gT o_gT [f [g Gf [fK gK]] [fM f1 fV]]]:
  {gT : finGroupType & #|gT| = n & {f : gT -> T
    & {g : _ & forall a, G (f a) & cancel f g /\ forall x, G x -> f (g x) = x}
      & [/\ {morph f : a b / a * b >-> mul a b}, f 1 = one
          & {morph f : a / a^-1 >-> inv a}]}}.
- pose gT := 'I_n.-1.+1; pose g x : gT := inord (Nnat (rG x)).
  have ub_rG x: G x -> Nnat (rG x) < n.
    move=> Gx; rewrite AltE ?NnatK //.
    by have [_] := im_rG (rG x); apply; exists x.
  have Dn: n.-1.+1 = n := ltn_predK (ub_rG one oneG).
  have fP a: {x : T & G x * (g x = a)}%type.
    have a_lt_n: Alt (natN a) nn by rewrite -(canLR NnatK Dn); apply: AltI.
    have [/(_ a_lt_n)[x Gx rGx] _] := im_rG (natN a).
    by exists x; split; rewrite // /g -rGx natN_K inord_val.
  pose f a := tag (fP a); have Gf a: G (f a) by rewrite /f; case: (fP) => x [].
  have fK: cancel f g by rewrite /f => a; case: (fP a) => x [].
  have Ng x & G x: natN (g x) = rG x by rewrite inordK ?Dn ?ub_rG ?NnatK.
  have{Ng} gK x: G x -> f (g x) = x.
    by move=> Gx; rewrite (inj_rG (f (g x)) x) // -!Ng ?fK.
  pose m a b := g (mul (f a) (f b)).
  pose o := g one; pose v a := g (inv (f a)).
  have fM: {morph f: a b / m a b >-> mul a b} by move=> a b; apply/gK/mulG.
  have f1: f o = one by apply: gK.
  have fV: {morph f: a / v a >-> inv a} by move=> a; apply/gK/invG.
  have mA: associative m by move=> a b c; apply: canLR fK _; rewrite !fM mulA.
  have m1: left_id o m by move=> a; apply: canLR fK _; rewrite f1 mul1T.
  have mV: left_inverse o v m.
    by move=> a; apply: canLR fK _; rewrite fV f1 mulVT.
  pose bT := BaseFinGroupType _ (FinGroup.Mixin mA m1 mV).
  exists (@FinGroupType bT mV); first by rewrite card_ord Dn.
  by exists f; first exists g.
pose im (H : {group gT}) x := (G x * (g x \in H))%type.
have imG H : Agroup T mul one inv (im H).
  split=> [x y [Gx Hx] [Gy Hy] | | x [Gx Hx]]; first 1 last.
  - by split; rewrite // -(canRL fK f1).
  - by split; [auto | rewrite -(gK x Gx) -fV fK groupV].
  by split; [auto | rewrite -(gK x Gx) -(gK y Gy) -fM fK groupM].
pose G0 := [set: gT]%G.
have sGG0 x: G x -> im G0 x by split; rewrite ?inE.
have mulVV1 x: mul (inv (inv x)) one = x by rewrite -(mulVT x) mulA mulVT mul1T.
have{mulVV1} mulT1 x: mul x one = x by rewrite -[x]mulVV1 -mulA mul1T.
pose comm x y := mul (mul x y) (inv (mul y x)).
suffices solH: Asol T mul one inv (im G0).
  right with (im G0) => //; split=> // [|x y Gx Gy].
    by split=> // [|x y [Gx _] Gy]; [split=> // x [] | apply: sGG0; auto].
  by exists (comm x y); [rewrite /comm; auto | rewrite -mulA mulVT -mulA mulT1].
have solG0: solvable G0 by rewrite PFsection14.Feit_Thompson ?cardsT ?o_gT.
elim: _.+1 {-2}G0 (ltnSn #|G0|) => // m IHm H; rewrite ltnS => leHm.
have [-> | ntH] := eqVneq H 1%G.
  left=> // x; split=> [[Gx /set1P] | ->].
    by rewrite -f1 => <-; rewrite gK.
  by split; rewrite // -f1 fK.
have ltH'H: H^`(1) \proper H := sol_der1_proper solG0 (subsetT H) ntH.
right with (im H^`(1)%G); first exact: IHm (leq_trans (proper_card _) leHm).
have /andP[/subsetP sH'H /subsetP nH'H]: H^`(1) <| H := der_normal 1 H.
split=> // [|x y [Gx Hx] [Gy Hy]].
  split=> // [|x y [Gx H'x] [Gy Hy]]; first by split=> // x [Gx /sH'H].
  split; first by [auto]; rewrite -(gK x Gx) -(gK y Gy) -!(fM, fV) !fK.
  by rewrite memJ_norm ?nH'H.
exists (comm x y); last by rewrite -mulA mulVT -mulA mulT1.
rewrite /comm; split; first by [auto]; rewrite -(gK x Gx) -(gK y Gy).
by rewrite -!(fM, fV) fK -[g x * g y]invgK !invMg -mulgA mem_commg ?groupV.
Qed.

End InternalSkepticOddOrderProof.
(* end hide *)

(* The Odd Order theorem *)

Theorem stripped_Odd_Order T mul one inv (G : T -> Type) (n : natural) :
    group_axioms T mul one inv -> group T mul one inv G ->
    finite_of_order T G n -> odd n ->
  solvable_group T mul one inv G.
Proof. exact (InternalSkepticOddOrderProof.main T mul one inv G n). Qed.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__8__3.
Require Export lemma__NCdistinct.
Require Export lemma__NChelper.
Require Export lemma__NCorder.
Require Export lemma__PGrectangle.
Require Export lemma__PGrotate.
Require Export lemma__betweennotequal.
Require Export lemma__collinearorder.
Require Export lemma__collinearright.
Require Export lemma__congruencesymmetric.
Require Export lemma__equaltorightisright.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__layoff.
Require Export lemma__oppositesideflip.
Require Export lemma__paste5.
Require Export lemma__rectanglerotate.
Require Export lemma__rightangleNC.
Require Export lemma__squaresequal.
Require Export logic.
Require Export proposition__08.
Require Export proposition__11B.
Require Export proposition__46.
Require Export proposition__47.
Require Export proposition__48A.
Definition proposition__48 : forall A B C D E F G H K L M, (euclidean__axioms.Triangle A B C) -> ((euclidean__defs.SQ A B F G) -> ((euclidean__defs.SQ A C K H) -> ((euclidean__defs.SQ B C E D) -> ((euclidean__axioms.BetS B M C) -> ((euclidean__axioms.BetS E L D) -> ((euclidean__axioms.EF A B F G B M L D) -> ((euclidean__axioms.EF A C K H M C E L) -> ((euclidean__defs.RE M C E L) -> (euclidean__defs.Per B A C))))))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro F.
intro G.
intro H.
intro K.
intro L.
intro M.
intro H0.
intro H1.
intro H2.
intro H3.
intro H4.
intro H5.
intro H6.
intro H7.
intro H8.
assert (euclidean__axioms.nCol A B C) as H9 by exact H0.
assert (* Cut *) (euclidean__axioms.neq A C) as H10.
- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C A)))))) as H10.
-- apply (@lemma__NCdistinct.lemma__NCdistinct A B C H9).
-- destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H15.
- assert (* Cut *) (euclidean__axioms.neq A B) as H11.
-- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C A)))))) as H11.
--- apply (@lemma__NCdistinct.lemma__NCdistinct A B C H9).
--- destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H12.
-- assert (* Cut *) (euclidean__axioms.neq B A) as H12.
--- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H11).
--- assert (* Cut *) (exists R, (euclidean__axioms.BetS B A R) /\ (euclidean__axioms.Cong A R A B)) as H13.
---- apply (@lemma__extension.lemma__extension B A A B H12 H11).
---- destruct H13 as [R H14].
destruct H14 as [H15 H16].
assert (* Cut *) (euclidean__axioms.Col B A R) as H17.
----- right.
right.
right.
right.
left.
exact H15.
----- assert (* Cut *) (euclidean__axioms.Col A B R) as H18.
------ assert (* Cut *) ((euclidean__axioms.Col A B R) /\ ((euclidean__axioms.Col A R B) /\ ((euclidean__axioms.Col R B A) /\ ((euclidean__axioms.Col B R A) /\ (euclidean__axioms.Col R A B))))) as H18.
------- apply (@lemma__collinearorder.lemma__collinearorder B A R H17).
------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H19.
------ assert (* Cut *) (B = B) as H19.
------- apply (@logic.eq__refl Point B).
------- assert (* Cut *) (euclidean__axioms.Col A B B) as H20.
-------- right.
right.
left.
exact H19.
-------- assert (* Cut *) (euclidean__axioms.neq B R) as H21.
--------- assert (* Cut *) ((euclidean__axioms.neq A R) /\ ((euclidean__axioms.neq B A) /\ (euclidean__axioms.neq B R))) as H21.
---------- apply (@lemma__betweennotequal.lemma__betweennotequal B A R H15).
---------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H25.
--------- assert (* Cut *) (euclidean__axioms.neq R B) as H22.
---------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B R H21).
---------- assert (* Cut *) (euclidean__axioms.nCol R B C) as H23.
----------- apply (@euclidean__tactics.nCol__notCol R B C).
------------apply (@euclidean__tactics.nCol__not__Col R B C).
-------------apply (@lemma__NChelper.lemma__NChelper A B C R B H9 H18 H20 H22).

----------- assert (* Cut *) (euclidean__axioms.nCol B R C) as H24.
------------ assert (* Cut *) ((euclidean__axioms.nCol B R C) /\ ((euclidean__axioms.nCol B C R) /\ ((euclidean__axioms.nCol C R B) /\ ((euclidean__axioms.nCol R C B) /\ (euclidean__axioms.nCol C B R))))) as H24.
------------- apply (@lemma__NCorder.lemma__NCorder R B C H23).
------------- destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H25.
------------ assert (* Cut *) (exists Q, (euclidean__defs.Per B A Q) /\ (euclidean__axioms.TS Q B R C)) as H25.
------------- apply (@proposition__11B.proposition__11B B R A C H15 H24).
------------- destruct H25 as [Q H26].
destruct H26 as [H27 H28].
assert (* Cut *) (euclidean__axioms.nCol B A Q) as H29.
-------------- apply (@lemma__rightangleNC.lemma__rightangleNC B A Q H27).
-------------- assert (* Cut *) (euclidean__axioms.neq A Q) as H30.
--------------- assert (* Cut *) ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq A Q) /\ ((euclidean__axioms.neq B Q) /\ ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq Q A) /\ (euclidean__axioms.neq Q B)))))) as H30.
---------------- apply (@lemma__NCdistinct.lemma__NCdistinct B A Q H29).
---------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H33.
--------------- assert (* Cut *) (exists c, (euclidean__defs.Out A Q c) /\ (euclidean__axioms.Cong A c A C)) as H31.
---------------- apply (@lemma__layoff.lemma__layoff A Q A C H30 H10).
---------------- destruct H31 as [c H32].
destruct H32 as [H33 H34].
assert (* Cut *) (euclidean__defs.Per B A c) as H35.
----------------- apply (@lemma__8__3.lemma__8__3 B A Q c H27 H33).
----------------- assert (* Cut *) (euclidean__axioms.nCol B A c) as H36.
------------------ apply (@lemma__rightangleNC.lemma__rightangleNC B A c H35).
------------------ assert (* Cut *) (euclidean__axioms.nCol A B c) as H37.
------------------- assert (* Cut *) ((euclidean__axioms.nCol A B c) /\ ((euclidean__axioms.nCol A c B) /\ ((euclidean__axioms.nCol c B A) /\ ((euclidean__axioms.nCol B c A) /\ (euclidean__axioms.nCol c A B))))) as H37.
-------------------- apply (@lemma__NCorder.lemma__NCorder B A c H36).
-------------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H38.
------------------- assert (* Cut *) (exists f g, (euclidean__defs.SQ A B f g) /\ ((euclidean__axioms.TS g A B c) /\ (euclidean__defs.PG A B f g))) as H38.
-------------------- apply (@proposition__46.proposition__46 A B c H11 H37).
-------------------- destruct H38 as [f H39].
destruct H39 as [g H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
assert (* Cut *) (euclidean__axioms.neq A c) as H45.
--------------------- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B c) /\ ((euclidean__axioms.neq A c) /\ ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq c B) /\ (euclidean__axioms.neq c A)))))) as H45.
---------------------- apply (@lemma__NCdistinct.lemma__NCdistinct A B c H37).
---------------------- destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
exact H50.
--------------------- assert (* Cut *) (euclidean__axioms.nCol A c B) as H46.
---------------------- assert (* Cut *) ((euclidean__axioms.nCol B A c) /\ ((euclidean__axioms.nCol B c A) /\ ((euclidean__axioms.nCol c A B) /\ ((euclidean__axioms.nCol A c B) /\ (euclidean__axioms.nCol c B A))))) as H46.
----------------------- apply (@lemma__NCorder.lemma__NCorder A B c H37).
----------------------- destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
exact H53.
---------------------- assert (* Cut *) (exists k h, (euclidean__defs.SQ A c k h) /\ ((euclidean__axioms.TS h A c B) /\ (euclidean__defs.PG A c k h))) as H47.
----------------------- apply (@proposition__46.proposition__46 A c B H45 H46).
----------------------- destruct H47 as [k H48].
destruct H48 as [h H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
assert (* Cut *) (euclidean__axioms.neq B c) as H54.
------------------------ assert (* Cut *) ((euclidean__axioms.neq A c) /\ ((euclidean__axioms.neq c B) /\ ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq c A) /\ ((euclidean__axioms.neq B c) /\ (euclidean__axioms.neq B A)))))) as H54.
------------------------- apply (@lemma__NCdistinct.lemma__NCdistinct A c B H46).
------------------------- destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
exact H63.
------------------------ assert (* Cut *) (euclidean__axioms.nCol B c A) as H55.
------------------------- assert (* Cut *) ((euclidean__axioms.nCol c A B) /\ ((euclidean__axioms.nCol c B A) /\ ((euclidean__axioms.nCol B A c) /\ ((euclidean__axioms.nCol A B c) /\ (euclidean__axioms.nCol B c A))))) as H55.
-------------------------- apply (@lemma__NCorder.lemma__NCorder A c B H46).
-------------------------- destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
exact H63.
------------------------- assert (* Cut *) (exists e d, (euclidean__defs.SQ B c e d) /\ ((euclidean__axioms.TS d B c A) /\ (euclidean__defs.PG B c e d))) as H56.
-------------------------- apply (@proposition__46.proposition__46 B c A H54 H55).
-------------------------- destruct H56 as [e H57].
destruct H57 as [d H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
assert (euclidean__axioms.Triangle A B c) as H63 by exact H37.
assert (* Cut *) (euclidean__axioms.TS g B A c) as H64.
--------------------------- apply (@lemma__oppositesideflip.lemma__oppositesideflip A B g c H43).
--------------------------- assert (* Cut *) (euclidean__axioms.TS h c A B) as H65.
---------------------------- apply (@lemma__oppositesideflip.lemma__oppositesideflip A c h B H52).
---------------------------- assert (* Cut *) (euclidean__axioms.TS d c B A) as H66.
----------------------------- apply (@lemma__oppositesideflip.lemma__oppositesideflip B c d A H61).
----------------------------- assert (* Cut *) (exists m l, (euclidean__defs.PG B m l d) /\ ((euclidean__axioms.BetS B m c) /\ ((euclidean__defs.PG m c e l) /\ ((euclidean__axioms.BetS d l e) /\ ((euclidean__axioms.EF A B f g B m l d) /\ (euclidean__axioms.EF A c k h m c e l)))))) as H67.
------------------------------ apply (@proposition__47.proposition__47 A B c d e f g h k H63 H35 H41 H64 H50 H65 H59 H66).
------------------------------ destruct H67 as [m H68].
destruct H68 as [l H69].
destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
assert (* Cut *) (euclidean__axioms.Cong A C A c) as H80.
------------------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A A c C H34).
------------------------------- assert (* Cut *) (euclidean__axioms.EF A C K H A c k h) as H81.
-------------------------------- apply (@lemma__squaresequal.lemma__squaresequal A C K H A c k h H80 H2 H50).
-------------------------------- assert (* Cut *) (euclidean__axioms.Cong A B A B) as H82.
--------------------------------- apply (@euclidean__axioms.cn__congruencereflexive A B).
--------------------------------- assert (* Cut *) (euclidean__axioms.EF A B F G A B f g) as H83.
---------------------------------- apply (@lemma__squaresequal.lemma__squaresequal A B F G A B f g H82 H1 H41).
---------------------------------- assert (* Cut *) (euclidean__axioms.EF A B F G B m l d) as H84.
----------------------------------- apply (@euclidean__axioms.axiom__EFtransitive A B F G B m l d A B f g H83 H78).
----------------------------------- assert (* Cut *) (euclidean__axioms.EF B M L D A B F G) as H85.
------------------------------------ apply (@euclidean__axioms.axiom__EFsymmetric A B F G B M L D H6).
------------------------------------ assert (* Cut *) (euclidean__axioms.EF B M L D B m l d) as H86.
------------------------------------- apply (@euclidean__axioms.axiom__EFtransitive B M L D B m l d A B F G H85 H84).
------------------------------------- assert (* Cut *) (euclidean__axioms.EF M C E L A C K H) as H87.
-------------------------------------- apply (@euclidean__axioms.axiom__EFsymmetric A C K H M C E L H7).
-------------------------------------- assert (* Cut *) (euclidean__axioms.EF M C E L A c k h) as H88.
--------------------------------------- apply (@euclidean__axioms.axiom__EFtransitive M C E L A c k h A C K H H87 H81).
--------------------------------------- assert (* Cut *) (euclidean__axioms.EF M C E L m c e l) as H89.
---------------------------------------- apply (@euclidean__axioms.axiom__EFtransitive M C E L m c e l A c k h H88 H79).
---------------------------------------- assert (* Cut *) (euclidean__axioms.BetS e l d) as H90.
----------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry d l e H76).
----------------------------------------- assert (* Cut *) (euclidean__defs.Per B c e) as H91.
------------------------------------------ destruct H59 as [H91 H92].
destruct H92 as [H93 H94].
destruct H94 as [H95 H96].
destruct H96 as [H97 H98].
destruct H98 as [H99 H100].
destruct H100 as [H101 H102].
destruct H50 as [H103 H104].
destruct H104 as [H105 H106].
destruct H106 as [H107 H108].
destruct H108 as [H109 H110].
destruct H110 as [H111 H112].
destruct H112 as [H113 H114].
destruct H41 as [H115 H116].
destruct H116 as [H117 H118].
destruct H118 as [H119 H120].
destruct H120 as [H121 H122].
destruct H122 as [H123 H124].
destruct H124 as [H125 H126].
destruct H3 as [H127 H128].
destruct H128 as [H129 H130].
destruct H130 as [H131 H132].
destruct H132 as [H133 H134].
destruct H134 as [H135 H136].
destruct H136 as [H137 H138].
destruct H2 as [H139 H140].
destruct H140 as [H141 H142].
destruct H142 as [H143 H144].
destruct H144 as [H145 H146].
destruct H146 as [H147 H148].
destruct H148 as [H149 H150].
destruct H1 as [H151 H152].
destruct H152 as [H153 H154].
destruct H154 as [H155 H156].
destruct H156 as [H157 H158].
destruct H158 as [H159 H160].
destruct H160 as [H161 H162].
exact H99.
------------------------------------------ assert (* Cut *) (euclidean__axioms.neq m c) as H92.
------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq m c) /\ ((euclidean__axioms.neq B m) /\ (euclidean__axioms.neq B c))) as H92.
-------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal B m c H72).
-------------------------------------------- destruct H92 as [H93 H94].
destruct H94 as [H95 H96].
exact H93.
------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B m c) as H93.
-------------------------------------------- right.
right.
right.
right.
left.
exact H72.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B c m) as H94.
--------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col m B c) /\ ((euclidean__axioms.Col m c B) /\ ((euclidean__axioms.Col c B m) /\ ((euclidean__axioms.Col B c m) /\ (euclidean__axioms.Col c m B))))) as H94.
---------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B m c H93).
---------------------------------------------- destruct H94 as [H95 H96].
destruct H96 as [H97 H98].
destruct H98 as [H99 H100].
destruct H100 as [H101 H102].
exact H101.
--------------------------------------------- assert (* Cut *) (euclidean__defs.Per m c e) as H95.
---------------------------------------------- apply (@lemma__collinearright.lemma__collinearright B c m e H91 H94 H92).
---------------------------------------------- assert (* Cut *) (euclidean__defs.PG c e l m) as H96.
----------------------------------------------- apply (@lemma__PGrotate.lemma__PGrotate m c e l H74).
----------------------------------------------- assert (* Cut *) (euclidean__defs.RE c e l m) as H97.
------------------------------------------------ apply (@lemma__PGrectangle.lemma__PGrectangle c m e l H96 H95).
------------------------------------------------ assert (* Cut *) (euclidean__defs.RE e l m c) as H98.
------------------------------------------------- apply (@lemma__rectanglerotate.lemma__rectanglerotate c e l m H97).
------------------------------------------------- assert (* Cut *) (euclidean__defs.RE l m c e) as H99.
-------------------------------------------------- apply (@lemma__rectanglerotate.lemma__rectanglerotate e l m c H98).
-------------------------------------------------- assert (* Cut *) (euclidean__defs.RE m c e l) as H100.
--------------------------------------------------- apply (@lemma__rectanglerotate.lemma__rectanglerotate l m c e H99).
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.EF B C E D B c e d) as H101.
---------------------------------------------------- apply (@lemma__paste5.lemma__paste5 B C D E L M B c d e l m H86 H89 H4 H72 H5 H90 H8 H100).
---------------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong B C B c) as H102.
----------------------------------------------------- apply (@proposition__48A.proposition__48A B C E D B c e d H3 H59 H101).
----------------------------------------------------- assert (euclidean__axioms.Cong A C A c) as H103 by exact H80.
assert (euclidean__axioms.Triangle A B c) as H104 by exact H63.
assert (* Cut *) (euclidean__defs.CongA B A C B A c) as H105.
------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Triangle A B C) -> ((euclidean__axioms.Triangle A B c) -> ((euclidean__axioms.Cong A B A B) -> ((euclidean__axioms.Cong A C A c) -> ((euclidean__axioms.Cong B C B c) -> (euclidean__defs.CongA B A C B A c)))))) as H105.
------------------------------------------------------- intro __.
intro __0.
intro __1.
intro __2.
intro __3.
assert (* AndElim *) ((euclidean__defs.CongA B A C B A c) /\ ((euclidean__defs.CongA C B A c B A) /\ (euclidean__defs.CongA A C B A c B))) as __4.
-------------------------------------------------------- apply (@proposition__08.proposition__08 A B C A B c __ __0 __1 __2 __3).
-------------------------------------------------------- destruct __4 as [__4 __5].
exact __4.
------------------------------------------------------- apply (@H105 H0 H104 H82 H103 H102).
------------------------------------------------------ assert (* Cut *) (euclidean__defs.Per B A C) as H106.
------------------------------------------------------- apply (@lemma__equaltorightisright.lemma__equaltorightisright B A c B A C H35 H105).
------------------------------------------------------- exact H106.
Qed.


Require Import Lia.
From hahn Require Import Hahn.
Require Import Setoid.

Set Implicit Arguments.

Lemma dom_eqv_seq {A} a (r r' : relation A) (NE : exists b, r' a b) :
  dom_rel (r ⨾ ⦗eq a⦘ ) ≡₁ dom_rel (r ⨾ ⦗eq a⦘ ⨾ r').
Proof using.
  split.
  2: { rewrite <- !seqA. apply dom_seq. }
  unfolder. ins. desf. eauto.
Qed.

Add Parametric Morphism A : (@set_union A) with signature
  set_equiv ==> set_equiv ==> set_equiv as set_union_more.
Proof using. red; unfolder; splits; ins; desf; eauto. Qed.

Add Parametric Morphism A : (@set_union A) with signature
  set_subset ==> set_subset ==> set_subset as set_union_mori.
Proof using. red; unfolder; splits; ins; desf; eauto. Qed.

Lemma codom_rel_helper {A} (r : relation A) (d : A -> Prop) (HH : codom_rel r ⊆₁ d) :
  r ≡ r ⨾ ⦗d⦘.
Proof using.
  split; [|basic_solver].
  unfolder. ins. split; auto. apply HH. red. eauto.
Qed.

Lemma inter_inclusion {A : Type} (r r' : relation A) (IN : r ⊆ r') :
  r ⊆ r ∩ r'.
Proof using. basic_solver. Qed.

Lemma inter_eq {A : Type} (r r' : relation A) (EQ : r ≡ r') : r ≡ r ∩ r'.
Proof using. generalize EQ. basic_solver. Qed.

Lemma forall_not_or_exists {A} (s P : A -> Prop):
  (exists e, s e /\ P e) \/ (forall e, s e -> ~ P e).
Proof using. apply NNPP. intros X. firstorder. Qed.

Lemma tot_ext_nat_extends2 (r : relation nat) : r⁺ ⊆ tot_ext_nat r.
Proof using.
  apply inclusion_t_ind; try apply tot_ext_nat_trans.
  red; ins.
    by apply tot_ext_nat_extends.
Qed.

Lemma pair_app :
  forall (A B : Prop), A -> (A -> A /\ B) -> A /\ B.
Proof using. ins. intuition. Qed.

Theorem nat_ind_lt (P : nat -> Prop)
        (HPi : forall n, (forall m, m < n -> P m) -> P n) :
  forall n, P n.
Proof using.
  set (Q n := forall m, m <= n -> P m).
  assert (forall n, Q n) as HH.
  2: { ins. apply (HH n). lia. }
  ins. induction n.
  { unfold Q. ins. inv H. apply HPi. ins. inv H0. }
  unfold Q in *. ins.
  apply Compare_dec.le_lt_eq_dec in H.
  destruct H as [Hl | Heq].
  { unfold lt in Hl. apply le_S_n in Hl. by apply IHn. }
  rewrite Heq. apply HPi. ins.
  apply le_S_n in H. by apply IHn.
Qed.

Lemma immediate_inter_mori {A} (x y : relation A) (IN : y ⊆ x) :
  y ∩ (immediate x) ⊆ immediate y.
Proof using.
  intros e e' [HH BB].
  split; auto.
  ins. eapply BB; apply IN; eauto.
Qed.

Lemma seq_codom_dom_inter  {A} (r r' : relation A) :
  codom_rel r ∩₁ dom_rel r' ≡₁ ∅ -> r ⨾ r' ≡ ∅₂.
Proof using.
  unfold set_equiv, set_subset; ins; desf.
  unfold same_relation; splits; [|basic_solver].
  unfold seq, inclusion.
  intros x y [z HH].
  specialize (H z).
  apply H.
  basic_solver.
Qed.

Lemma seq_codom_dom_inter_iff {A} (r r' : relation A) :
  codom_rel r ∩₁ dom_rel r' ≡₁ ∅ <-> r ⨾ r' ≡ ∅₂.
Proof using.
  ins. split.
  { by apply seq_codom_dom_inter. }
  intros AA.
  split; [|basic_solver].
  unfolder. ins. desf.
  eapply AA. eexists. eauto.
Qed.

Lemma length_nzero_in A (l : list A) n : length l = S n -> exists x, In x l.
Proof using.
  destruct l; ins; desf; eauto.
Qed.

Lemma r_to_dom_rel_r_r {A} (r: relation A) : r ≡ ⦗dom_rel r⦘ ⨾ r.
Proof using. basic_solver. Qed.

Lemma r_to_r_codom_rel_r {A} (r: relation A) : r ≡ r ⨾ ⦗codom_rel r⦘.
Proof using. basic_solver. Qed.


(* scratch.v  *)

Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.

Variables A : Type.

Parameter RR: A * A -> A * A  -> Prop.

Axiom RR_refl: forall ab, RR ab ab.
Axiom RR_trans: forall a b c, RR a b -> RR b c -> RR a c.

Parameter O : A -> A -> Prop.
Axiom O_refl: forall ab, RR ab ab.
Axiom O_trans: forall a b c, RR a b -> RR b c -> RR a c.
Parameter P : A -> A -> Prop.
Axiom P_refl: forall ab, RR ab ab.
Axiom P_trans: forall a b c, RR a b -> RR b c -> RR a c.
Parameter S: A * A -> A.

Fixpoint R (n: nat) (i j :A ) : Prop:=
  match n with
    | 0 => i = j
    | n.+1 => exists h, (O i h \/ P i h) /\ R n h j
  end.

(* Axiom e0: forall ab j, R 0 ab j -> E j ab. *)

Axiom R_refl: forall ab, RR ab ab.
Axiom R_trans: forall a b c, RR a b -> RR b c -> RR a c.

Definition H1 a b j:= exists n, R n (S (a , b)) j.

Lemma Lcross: forall (a b: A) (j : A),
   (H1 a b j) -> exists a' b', j = (S (a',b')) /\ RR (a,b) (a',b').
Proof.
move=> a b j [n] H; elim: n a b H=>[|n IH]a0 b0 /=.
+ by move=> H; exists a0, b0; split=>//; apply: RR_refl.
move=>[h]H.
suff: exists a1 b1, h = S (a1,b1) /\ RR (a0,b0) (a1,b1).
+ move=>[a1][b1][E]; rewrite E in H *; case: H=>H /IH[a2][b2][->].
 by move/(RR_trans _ _ _ _)=> H1 /H1 T; exists a2, b2;split=>//.
Admitted.


Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.EnumEnsembles.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.lib.relation_list.
Require Import CertiGraph.lib.Equivalence_ext.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.path_lemmas.

Section FiniteGraph.

Context {V E: Type} {EV: EqDec V eq} {EE: EqDec E eq}.

Class FiniteGraph (pg: PreGraph V E) :=
{
  finiteV: Enumerable V (vvalid pg);
  finiteE: Enumerable E (evalid pg)
}.

Definition VList (pg: PreGraph V E) {fg: FiniteGraph pg} := proj1_sig (finiteV).
Definition EList (pg: PreGraph V E) {fg: FiniteGraph pg} := proj1_sig (finiteE).

(*trivial lemmas*)
Lemma NoDup_VList:
  forall (pg: PreGraph V E) {fg: FiniteGraph pg}, NoDup (VList pg).
Proof.
unfold VList; intros. destruct finiteV. unfold proj1_sig. apply a.
Qed.

Corollary NoDup_Perm_VList:
  forall (pg: PreGraph V E) {fg: FiniteGraph pg} (l: list V), Permutation l (VList pg) -> NoDup l.
Proof.
intros. apply (Permutation_NoDup (l:=VList pg)). apply Permutation_sym; auto. apply NoDup_VList.
Qed.

Lemma NoDup_EList:
  forall (pg: PreGraph V E) {fg: FiniteGraph pg}, NoDup (EList pg).
Proof.
unfold EList; intros. destruct finiteE. unfold proj1_sig. apply a.
Qed.

Corollary NoDup_Perm_EList:
  forall (pg: PreGraph V E) {fg: FiniteGraph pg} (l: list E), Permutation l (EList pg) -> NoDup l.
Proof.
intros. apply (Permutation_NoDup (l:=EList pg)). apply Permutation_sym; auto. apply NoDup_EList.
Qed.

Lemma VList_vvalid:
  forall (pg: PreGraph V E) {fg: FiniteGraph pg} v, In v (VList pg) <-> vvalid pg v.
Proof.
intros. unfold VList. destruct finiteV. simpl. apply a.
Qed.

Lemma EList_evalid:
  forall (pg: PreGraph V E) {fg: FiniteGraph pg} e, In e (EList pg) <-> evalid pg e.
Proof.
intros. unfold EList. destruct finiteE. simpl. apply a.
Qed.

(*destructing In_dec (VList g) can be slow outside, so adding this here*)
Lemma VList_In_dec:
  forall g {fg: FiniteGraph g} v, In v (VList g) \/ ~ In v (VList g).
Proof.
intros. destruct (in_dec EV v (VList g)); [left; auto | right; auto].
Qed.

Lemma EList_In_dec:
  forall g {fg: FiniteGraph g} e, In e (EList g) \/ ~ In e (EList g).
Proof.
intros. destruct (in_dec EE e (EList g)); [left; auto | right; auto].
Qed.

Corollary vvalid_dec:
  forall g {fg: FiniteGraph g} v, {vvalid g v} + {~ vvalid g v}.
Proof.
intros. destruct (in_dec EV v (VList g)). rewrite VList_vvalid in i; left; auto.
rewrite VList_vvalid in n; right; auto.
Qed.

Corollary evalid_dec:
  forall g {fg: FiniteGraph g} e, {evalid g e} + {~ evalid g e}.
Proof.
intros. destruct (in_dec EE e (EList g)). rewrite EList_evalid in i. left; auto.
rewrite EList_evalid in n. right; auto.
Qed.

Corollary strong_evalid_dec:
  forall g {fg: FiniteGraph g} e, {strong_evalid g e} + {~ strong_evalid g e}.
Proof.
intros. destruct (evalid_dec g e).
destruct (vvalid_dec g (src g e)).
destruct (vvalid_dec g (dst g e)).
left. split. auto. split; auto.
all: right; unfold not; intros Htmp; destruct Htmp as [? [? ?]]; contradiction.
Qed.

(*I'm hoping to use Zlength instead. But maybe we can leave numV and numE in WeightedEdgeListGraph until we need it elsewhere*)
Definition numV' g {fg: FiniteGraph g} := length (VList g).
Definition numE' g {fg: FiniteGraph g} := length (EList g).

(****EDGE ADD/REMOVE*****)
#[export] Instance pregraph_add_edge_finite g {fg: FiniteGraph g} e u v:
  FiniteGraph (pregraph_add_edge g e u v).
Proof.
constructor; unfold EnumEnsembles.Enumerable; simpl.
exists (VList g). split. apply NoDup_VList. apply VList_vvalid.
(*edge*)
unfold addValidFunc. destruct (in_dec EE e (EList g)).
(*case e already inside*)
exists (EList g). split. apply NoDup_EList. intros; split; intros. left. apply EList_evalid in H; auto.
destruct H. apply EList_evalid; auto. rewrite H; auto.
(*case e not inside*)
exists (e::(EList g)). split. apply NoDup_cons. auto. apply NoDup_EList.
intros; split; intros.
destruct H. right; rewrite H; auto. left; rewrite <- EList_evalid; apply H.
destruct H. rewrite <- EList_evalid in H. apply in_cons. apply H.
rewrite H. simpl. left; auto.
Qed.

#[export] Instance pregraph_remove_edge_finite g {fg: FiniteGraph g} e :
  FiniteGraph (pregraph_remove_edge g e).
Proof.
unfold pregraph_remove_edge.
constructor; unfold Enumerable; simpl.
exists (VList g). split. apply NoDup_VList. apply VList_vvalid.
(*edge*)
unfold removeValidFunc.
destruct (in_dec EE e (EList g)).
(*case e already inside*)
exists (remove EE e (EList (g))). split.
apply nodup_remove_nodup. apply NoDup_EList.
intros. rewrite remove_In_iff. rewrite EList_evalid. split; auto.
(*case e not inside*)
exists (EList g). split. apply NoDup_EList.
intros; split; intros. split. apply EList_evalid in H; auto.
unfold not; intros; subst x. contradiction.
destruct H. apply EList_evalid. auto.
Qed.

Lemma pregraph_remove_edge_EList:
  forall g {fg: FiniteGraph g} e l, Permutation (e::l) (EList g) ->
    Permutation l (EList (pregraph_remove_edge g e)).
Proof.
intros. assert (Hel: NoDup (e::l)). apply NoDup_Perm_EList in H; auto.
apply NoDup_Permutation.
apply NoDup_cons_1 in Hel; auto.
apply NoDup_EList.
intros. rewrite EList_evalid. simpl. unfold removeValidFunc. rewrite <- EList_evalid. split; intros.
split. apply (Permutation_in (l:=(e::l))). apply H. right; auto.
unfold not; intros. subst e. apply NoDup_cons_2 in Hel. contradiction.
destruct H0. apply Permutation_sym in H. apply (Permutation_in (l':=(e::l))) in H0. 2: auto.
destruct H0. symmetry in H0; contradiction. auto.
Qed.

Lemma pregraph_remove_edge_EList':
  forall g {fg: FiniteGraph g} e l, evalid g e -> Permutation l (EList (pregraph_remove_edge g e)) -> Permutation (e::l) (EList g).
Proof.
intros. assert (~ In e (EList (pregraph_remove_edge g e))).
rewrite EList_evalid. simpl. unfold not, removeValidFunc; intros. destruct H1. contradiction.
assert (~ In e l). unfold not; intros.
apply (Permutation_in (l':= (EList (pregraph_remove_edge g e)))) in H2. contradiction. auto.
apply NoDup_Permutation. apply NoDup_cons; auto. apply NoDup_Perm_EList in H0; auto.
apply NoDup_EList.
intros; split; intros. apply EList_evalid. destruct H3. subst x. auto.
apply (Permutation_in (l':= (EList (pregraph_remove_edge g e)))) in H3; auto.
rewrite EList_evalid in H3. simpl in H3. unfold removeValidFunc in H3. apply H3.
destruct (EE x e). unfold equiv in e0. subst x. left; auto.
unfold complement, equiv in c. right.
assert (evalid (pregraph_remove_edge g e) x). simpl. unfold removeValidFunc. split; auto.
apply EList_evalid in H3; auto.
rewrite <- EList_evalid in H4.
apply (Permutation_in (l:= (EList (pregraph_remove_edge g e)))). apply Permutation_sym; auto. apply H4.
Qed.

(**************LOCAL FINITE GRAPH**************)

Class LocalFiniteGraph (pg: PreGraph V E) :=
{
  local_enumerable: forall x, Enumerable E (out_edges pg x)
}.

Definition edge_func (pg: PreGraph V E) {lfg: LocalFiniteGraph pg} x := proj1_sig (local_enumerable x).

Lemma edge_func_spec: forall {pg : PreGraph V E} {lfg: LocalFiniteGraph pg} e x,
  In e (edge_func pg x) <-> evalid pg e /\ src pg e = x.
Proof.
  intros.
  unfold edge_func.
  destruct (local_enumerable x) as [? [?H ?H]]; simpl.
  specialize (H0 e).
  rewrite H0; unfold out_edges.
  clear - H0.
  unfold Ensembles.In; tauto.
Qed.

Lemma edge_func_step: forall {pg : PreGraph V E} {lfg: LocalFiniteGraph pg} x y,
  step pg x y <-> In y (map (dst pg) (edge_func pg x)).
Proof.
  intros.
  rewrite step_spec.
  rewrite in_map_iff.
  apply Morphisms_Prop.ex_iff_morphism.
  hnf; cbv beta; intro e.
  rewrite edge_func_spec.
  clear - e.
  tauto.
Qed.

Lemma step_dec: forall {pg : PreGraph V E} {lfg: LocalFiniteGraph pg} x y,
  {step pg x y} + {~step pg x y}.
Proof.
  intros.
  destruct (in_dec EV y (map (dst pg) (edge_func pg x))).
  left. apply edge_func_step. trivial.
  right. intro. apply n. apply edge_func_step. trivial.
Qed.

#[export] Instance LocalFiniteGraph_FiniteGraph (g: PreGraph V E) (fg: FiniteGraph g): LocalFiniteGraph g.
Proof.
  intros.
  destruct fg as [[vs [?H ?H]] [es [?H ?H]]].
  constructor.
  intros.
  exists (filter (fun e => if equiv_dec (src g e) x then true else false) es).
  split.
  + apply NoDup_filter; auto.
  + intro e.
    rewrite filter_In.
    rewrite H2.
    unfold Ensembles.In, out_edges.
    destruct_eq_dec (src g e) x; [tauto |].
    assert (~ false = true) by congruence; tauto.
Defined.

Lemma finite_graph_si: forall (g1 g2: PreGraph V E),
  g1 ~=~ g2 ->
  FiniteGraph g1 ->
  FiniteGraph g2.
Proof.
  intros.
  destruct X as [X Y].
  constructor.
  + revert X; apply Enumerable_Same_set.
    destruct H as [? _]; rewrite Same_set_spec; auto.
  + revert Y; apply Enumerable_Same_set.
    destruct H as [_ [? _]]; rewrite Same_set_spec; auto.
Qed.

Lemma gen_dst_preserve_finite: forall (g: PreGraph V E) e t, FiniteGraph g -> FiniteGraph (pregraph_gen_dst g e t).
Proof.
  intros. apply Build_FiniteGraph; simpl.
  + apply finiteV.
  + apply finiteE.
Qed.

Lemma predicate_sub_finitegraph: forall (g: PreGraph V E) (p: NodePred V), FiniteGraph g -> FiniteGraph (predicate_subgraph g p).
Proof.
  intros.
  destruct X as [X Y].
  constructor.
  + destruct X as [l ?].
    exists (filter (fun v => if node_pred_dec p v then true else false) l); split.
    - apply NoDup_filter; tauto.
    - intros.
      unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
      rewrite filter_In.
      unfold Ensembles.In in *.
      assert (false <> true) by congruence.
      destruct (node_pred_dec p x); firstorder.
  + destruct Y as [l ?].
    exists (filter (fun e => if (Coqlib2.sumbool_dec_and (node_pred_dec p (src g e)) (node_pred_dec p (dst g e))) then true else false) l); split.
    - apply NoDup_filter; tauto.
    - intros e.
      unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
      rewrite filter_In.
      unfold Ensembles.In in *.
      assert (false <> true) by congruence.
      destruct (Coqlib2.sumbool_dec_and (node_pred_dec p (src g e)) (node_pred_dec p (dst g e))); firstorder.
Qed.

Lemma predicate_partial_finitegraph: forall (g: PreGraph V E) (p: NodePred V), FiniteGraph g -> FiniteGraph (predicate_partialgraph g p).
Proof.
  intros.
  destruct X as [X Y].
  constructor.
  + destruct X as [l ?].
    exists (filter (fun v => if node_pred_dec p v then true else false) l); split.
    - apply NoDup_filter; tauto.
    - intros.
      unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
      rewrite filter_In.
      unfold Ensembles.In in *.
      assert (false <> true) by congruence.
      destruct (node_pred_dec p x); firstorder.
  + destruct Y as [l ?].
    exists (filter (fun e => if (node_pred_dec p (src g e)) then true else false) l); split.
    - apply NoDup_filter; tauto.
    - intros e.
      unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
      rewrite filter_In.
      unfold Ensembles.In in *.
      assert (false <> true) by congruence.
      destruct (node_pred_dec p (src g e)); firstorder.
Qed.

Definition predicate_sub_localfinitegraph (g: PreGraph V E) (p: NodePred V) (LF: LocalFiniteGraph g): LocalFiniteGraph (predicate_subgraph g p).
Proof.
  refine (Build_LocalFiniteGraph _ _).
  intros.
  exists (filter (fun e => if (Coqlib2.sumbool_dec_and (node_pred_dec p (src g e)) (node_pred_dec p (dst g e))) then true else false) (edge_func g x)).
  split.
  + apply NoDup_filter.
    unfold edge_func.
    destruct (local_enumerable x); simpl.
    tauto.
  + intros.
    unfold predicate_subgraph, predicate_vvalid, predicate_evalid; simpl; intros.
    rewrite filter_In.
    rewrite edge_func_spec.
    destruct (Coqlib2.sumbool_dec_and (node_pred_dec p (src g x0)) (node_pred_dec p (dst g x0))).
    - unfold out_edges, Ensembles.In in *; simpl.
      assert (true = true) by auto; tauto.
    - unfold out_edges, Ensembles.In in *; simpl.
      assert (~ false = true) by congruence; tauto.
Defined.

Definition predicate_partial_localfinitegraph (g: PreGraph V E) (p: NodePred V) (LF: LocalFiniteGraph g) : LocalFiniteGraph (predicate_partialgraph g p).
Proof.
  refine (Build_LocalFiniteGraph _ _).
  intros.
  exists (filter (fun e => if (node_pred_dec p (src g e)) then true else false) (edge_func g x)).
  split.
  + apply NoDup_filter.
    unfold edge_func.
    destruct (local_enumerable x); simpl.
    tauto.
  + intros.
    unfold predicate_partialgraph, predicate_vvalid, predicate_weak_evalid; simpl; intros.
    rewrite filter_In.
    rewrite edge_func_spec.
    destruct (node_pred_dec p (src g x0)).
    - unfold out_edges, Ensembles.In in *; simpl.
      assert (true = true) by auto; tauto.
    - unfold out_edges, Ensembles.In in *; simpl.
      assert (~ false = true) by congruence; tauto.
Defined.

Lemma finite_graph_join: forall (g: PreGraph V E) (PV1 PV2 PV: V -> Prop) (PE1 PE2 PE: E -> Prop),
  Prop_join PV1 PV2 PV ->
  Prop_join PE1 PE2 PE ->
  FiniteGraph (gpredicate_subgraph PV1 PE1 g) ->
  FiniteGraph (gpredicate_subgraph PV2 PE2 g) ->
  FiniteGraph (gpredicate_subgraph PV PE g).
Proof.
  intros.
  constructor.
  + destruct X as [[l1 [?H ?H]] ?].
    destruct X0 as [[l2 [?H ?H]] ?].
    exists (l1 ++ l2).
    split.
    - apply NoDup_app_inv; auto.
      intros v ? ?.
      rewrite H2 in H5; rewrite H4 in H6.
      unfold Ensembles.In in H5, H6; simpl in H5, H6.
      rewrite Intersection_spec in H5, H6.
      destruct H5, H6, H as [_ ?].
      apply (H v); auto.
    - intros v.
      rewrite in_app_iff.
      rewrite H2, H4.
      unfold Ensembles.In; simpl; rewrite !Intersection_spec.
      destruct H as [? _]; specialize (H v); tauto.
  + destruct X as [? [l1 [?H ?H]]].
    destruct X0 as [? [l2 [?H ?H]]].
    exists (l1 ++ l2).
    split.
    - apply NoDup_app_inv; auto.
      intros e ? ?.
      rewrite H2 in H5; rewrite H4 in H6.
      unfold Ensembles.In in H5, H6; simpl in H5, H6.
      rewrite Intersection_spec in H5, H6.
      destruct H5, H6, H0 as [_ ?].
      apply (H0 e); auto.
    - intros e.
      rewrite in_app_iff.
      rewrite H2, H4.
      unfold Ensembles.In; simpl; rewrite !Intersection_spec.
      destruct H0 as [? _]; specialize (H0 e); tauto.
Qed.

Lemma FiniteGraph_EnumCovered: forall (g: PreGraph V E) (fin: FiniteGraph g) x, EnumCovered V (reachable g x).
Proof.
  intros.
  destruct fin as [[xs [? ?]] _].
  exists xs.
  split; auto.
  intros y ?.
  apply reachable_foot_valid in H1.
  rewrite H0.
  exact H1.
Qed.

Class ReachableFiniteGraph (pg: PreGraph V E) := {
  finiteR: forall x, vvalid pg x -> Enumerable V (reachable pg x)
}.

Lemma construct_reachable_list: forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} x, Decidable (vvalid g x) -> {l: list V | NoDup l /\ reachable_list g x l}.
Proof.
  intros.
  destruct H.
  + destruct (finiteR x v) as [l ?H].
    exists l.
    unfold reachable_list; auto.
  + exists nil.
    split; [constructor |].
    intro; simpl.
    pose proof reachable_head_valid g x y.
    tauto.
Qed.

Lemma RFG_reachable_decicable: forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} x y, vvalid g x -> Decidable (reachable g x y).
Proof.
  intros.
  pose proof finiteR x H.
  destruct X as [l [_ ?H]].
  unfold Ensembles.In in H0.
  destruct (in_dec equiv_dec y l); [left | right]; rewrite <- H0; auto.
Qed.

Lemma RFG_reachable_decicable': forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} x y, Decidable (vvalid g x) -> Decidable (reachable g x y).
Proof.
  intros.
  destruct H; [apply RFG_reachable_decicable; auto | right].
  intro.
  apply reachable_head_valid in H; tauto.
Qed.

Lemma construct_reachable_set_list: forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} S
  (V_DEC: forall x, In x S -> Decidable (vvalid g x)),
  {l: list V | NoDup l /\ reachable_set_list g S l}.
Proof.
  intros.
  induction S.
  + exists nil.
    split; [constructor |].
    intro.
    pose proof reachable_through_empty g.
    pose proof Empty_set_iff V.
    unfold Same_set, Included, Ensembles.In in *.
    simpl.
    firstorder.
  + spec IHS.
    - intros; apply V_DEC.
      right; auto.
    - destruct IHS as [l2 ?H].
      destruct (construct_reachable_list g a (V_DEC a (or_introl eq_refl))) as [l1 ?H].
      exists (nodup equiv_dec (l1 ++ l2)).
      split; [apply NoDup_nodup |].
      destruct H as [_ ?].
      destruct H0 as [_ ?].
      unfold reachable_set_list, reachable_list in *.
      intros.
      rewrite nodup_In.
      rewrite in_app_iff, reachable_through_set_eq.
      specialize (H x).
      specialize (H0 x).
      tauto.
Qed.

Lemma RFG_reachable_through_set_decicable: forall (g: PreGraph V E) {rfg: ReachableFiniteGraph g} S y, (forall x, In x S -> Decidable (vvalid g x)) -> Decidable (reachable_through_set g S y).
Proof.
  intros.
  destruct (construct_reachable_set_list g S X) as [l [_ ?]].
  destruct (in_dec equiv_dec y l); [left | right]; rewrite <- (H y); auto.
Qed.

End FiniteGraph.


Require Import
  Coq.Program.Program Omega Ssreflect.ssreflect Ssreflect.ssrnat Ssreflect.seq.

Set Implicit Arguments.

Ltac ssromega := rewrite ?NatTrec.trecE -?plusE -?minusE -?multE; omega.

Fixpoint t (n : nat) : Set :=
  (if n is n.+1 then option (t n) else Empty_set)%type.

Definition rect_case0 : forall (P : t 0 -> Type) p, P p.
Proof.
  move=> P; case.
Defined.

Definition rect_caseS :
  forall P : forall n, t n.+1 -> Type,
  (forall n, P n None) -> (forall n (p : t n), P n (Some p)) ->
  forall n (p : t n.+1), P n p.
Proof.
  move=> P H0 H1; case; simpl.
  - case; [case | apply H0].
  - move=> n; case.
    - move=> p; apply H1.
    - apply H0.
Defined.

Definition rect_case :
  forall P : forall n : nat, t n -> Type,
  (forall n, P n.+1 None) -> (forall n (p : t n), P n.+1 (Some p)) ->
  forall n p, P n p.
Proof.
  by move=> P H0 H1; case; last move=> n //=; case.
Defined.

Definition rectS :
  forall P : forall n : nat, t n.+1 -> Type,
  (forall n, P n None) -> (forall n p, P n p -> P n.+1 (Some p)) ->
  forall n p, P n p.
Proof.
  move=> P H0 H1; elim; simpl.
  - case; [case | apply H0].
  - move=> n IHn; case.
    - by move=> p; apply H1.
    - apply H0.
Defined.

Definition rect :
  forall P : forall n : nat, t n -> Type,
  (forall n, P n.+1 None) -> (forall n p, P n p -> P n.+1 (Some p)) ->
  forall n p, P n p.
Proof.
  move=> P H0 H1; elim; first case.
  move=> n IH //=; case; auto.
Defined.

Definition to_nat (n : nat) (a : t n) : nat :=
  rect (fun _ _ => nat) (fun _ => 0) (fun _ _ n => n.+1) n a.

Definition of_nat : forall (n m : nat), t m.+1.
Proof.
  elim.
  - by move=> m; apply None.
  - simpl=> n IHn; case.
    - by apply None.
    - move=> m; apply Some, IHn.
Defined.

Lemma to_nat_range : forall n a, lt (to_nat n a) n.
Proof.
  apply rect => //= [n | n p IH]; ssromega.
Qed.

Lemma to_nat_of_nat_inv : forall n a, a = of_nat (to_nat n.+1 a) n.
Proof.
  by apply rectS=> //= n p H; f_equal.
Qed.

Lemma to_nat_eq_conserve :
  forall n m a b, n = m -> (a ~= b <-> to_nat n a = to_nat m b).
Proof.
  move=> n m a b H; split.
  - by move: b; rewrite -H=> b H0; f_equal; apply JMeq_eq.
  - move: n a m b H; refine (rect _ _ _)=> n.
    - by refine (rect_case _ _ _)=> //= m; case=> H _; rewrite H.
    - move=> a IHa; refine (rect_case _ _ _)=> m //= b.
      by case=> H; case=> H0; rewrite (IHa _ _ H H0).
Qed.

Definition L n m (a : t n) : t (n + m).
Proof.
  move: n a; apply rect=> n //=.
  - by apply None.
  - by move=> _ r; apply Some.
Defined.

Fixpoint R n m (a : t n) : t (m + n) :=
  match m with
    | 0 => a
    | S m => Some (R n m a)
  end.

Definition plus n m (a : t n) (b : t m) : t (n + m).-1.
Proof.
  move: n a; apply rect=> n.
  - rewrite //= -/addn addnC.
    apply (L m n b).
  - case: n; first case.
    simpl=> n _ r; apply Some; apply r.
Defined.

Lemma L_sanity : forall n m a, to_nat n a = to_nat (n + m) (L n m a).
Proof.
  move=> n m; move: n; apply rect=> //= n a IHa; f_equal; apply IHa.
Qed.

Lemma R_sanity : forall n m a, m + to_nat n a = to_nat (m + n) (R n m a).
Proof.
  by move=> n; elim=> //= m IHm a; rewrite /addn //=; f_equal.
Qed.

Lemma plus_to_nat_distr :
  forall n m a b, to_nat n a + to_nat m b = to_nat (n + m).-1 (plus n m a b).
Proof.
  move=> n m a b; move: n a; apply rect=> n.
  - rewrite /addn //= -/addn /eq_rec_r /eq_rec /eq_rect.
    case (eq_sym (addnC n m)); apply L_sanity.
  - rewrite {2}(lock plus) //= -/addn; unlock.
    case: n; first case.
    by move=> n; rewrite /addn => //= p H; f_equal.
Qed.

Lemma plus_comm : forall n m a b, plus n m a b ~= plus m n b a.
Proof.
  move=> n m a b; rewrite to_nat_eq_conserve; last ssromega.
  rewrite -!plus_to_nat_distr; move: n a; apply rect=> //= n a; ssromega.
Qed.

Fixpoint enumerate_fin n : seq (t n) :=
  if n is n.+1
    then None :: map Some (enumerate_fin n)
    else [::].

Goal forall n v, foldr (fun v' p => v = v' \/ p) False (enumerate_fin n).
Proof.
  apply rect=> //= n.
  - by left.
  - move=> v' IH; right; move: IH.
    elim (enumerate_fin n)=> //= v vs IH; case.
    - by left; f_equal.
    - auto.
Qed.


From RecordUpdate Require Import RecordUpdate.

Record X := mkX { A: nat; B: nat; C: bool }.
(* you can omit the X; it's there to clarify the Settable class for the paper *)
#[export] Instance: Settable X := settable! mkX <A; B; C>.

Definition add3_to_B x := set B (plus 3) x.
Definition setB_to_3 x := set B (fun _ => 3) x.
Definition setB_to_3_notation x := x <|B:=3|>.

#[export] Instance set_B : Setter B := _.

Theorem set_B_convertible_to f x :
  set_B f x =
  let a := x.(A) in
  let b' := f x.(B) in
  let c := x.(C) in
  mkX a b' c.
Proof. reflexivity. Qed.

Theorem set_B_is f x :
  set_B f x =
  mkX x.(A) (f x.(B)) x.(C).
Proof.
  unfold set_B.
  Show.
  match goal with
  | |- ?x = ?x => reflexivity
  | _ => fail 1 "not an exact match"
  end.
Qed.

Theorem simpl_behavior x :
  (set A (fun _ => 2) (set B (fun _ => 3) x)).(B) = 3.
Proof.
  simpl.
  Show.
  match goal with
  | |- ?x = ?x => reflexivity
  | _ => fail 1 "did not simplify correctly"
  end.
Qed.

Fail Definition error_not_field := set plus.

Definition get_A x := A x.
(* the Ltac produces a better error message, but typeclass resolution swallows
up the error *)
Fail Definition error_not_proj := set get_A.

Record several_nats :=
  { nat1: nat; nat2: nat; nat3: nat; }.

Definition add2 (x:several_nats) := nat1 x + nat2 x.
Definition nat1_synonym x := nat1 x.

(* fails with a typechecking error, because the constructed identity function
doesn't typecheck (we could do better by using tactics-in-terms to fail with a
custom error message) *)
Fail #[export] Instance: Settable _ := settable! Build_several_nats <nat1; nat3>.
(* fails because fields are out-of-order *)
Fail #[export] Instance: Settable _ := settable! Build_several_nats <nat1; nat3; nat2>.
(* one of these just isn't a field, so the result isn't an identity function *)
Fail #[export] Instance: Settable _ := settable! Build_several_nats <add2; nat2; nat3>.
(* this isn't intentionally supported, but now we can only set nat1 via its
synonym (actually, the only thing special about nat1 vs nat1_synonym is that Coq
auto-generated nat1) *)
#[export] Instance: Settable _ := settable! Build_several_nats <nat1_synonym; nat2; nat3>.

(* this no longer works because the Settable several_nats doesn't say anything
about nat1 *)
Fail Definition set_nat1 f (x: several_nats) := set nat1 f x.
Definition set_nat1 f (x: several_nats) := set nat1_synonym f x.